Generating wrappers for execution in non-root non-Guix contexts

[Ludovic Courtès]

Hello Guix!

The hack below allows ‘guix pack’ to produce wrappers that allow,
through user namespaces, programs to automatically relocate themselves
when you run them unprivileged on a machine that lacks Guix.  In the
example below, I run ‘sed’ from a pack on a machine that lacks Guix:

--8<---------------cut here---------------start------------->8---
address@hidden:~/tmp$ tar xf ../pack.tgz
address@hidden:~/tmp$ echo hello > foo
address@hidden:~/tmp$ 
gnu/store/ffdzkyi23n8xh3n6vfqpa1lzg3xx9jpj-sed-4.4/bin/sed -i foo 
-es/hello/bye/g
address@hidden:~/tmp$ cat foo
bye
address@hidden:~/tmp$ ls /gnu/store
ls: cannot access '/gnu/store': No such file or directory
--8<---------------cut here---------------end--------------->8---

Pretty cool no?

What I imagine is that we could make this an option of ‘guix pack’, such
that ‘guix pack -w’ would produce such binaries.

This relies on the same approach as ‘call-with-container’… except it’s
written in C and statically-linked to avoid bootstrapping issues.  Doing
that in Scheme would be a bit involved because a shebang like
#!/gnu/store/…-guile/bin/guile wouldn’t work; the wrappers have to be
statically-linked executables.

There are (minor) issues to be solved: symlinks created by ‘guix pack
-S’ should be relative instead of absolute, and same for symlinks in the
profile.  This would allow users to directly type ./bin/sed instead of
having to find out which directory is the right one as in the example
above.

We could also have wrappers fall back to PRoot when unshare(2) fails.

What do people think?

Cheers,
Ludo’.

diff --git a/gnu/packages/commencement.scm b/gnu/packages/commencement.scm
index fe9fbebcc..1026ee892 100644
--- a/gnu/packages/commencement.scm
+++ b/gnu/packages/commencement.scm
@@ -1026,7 +1026,10 @@ COREUTILS-FINAL vs. COREUTILS, etc."
 
                      (union-build (assoc-ref %outputs "debug")
                                   (list (assoc-ref %build-inputs
-                                                   "libc-debug")))))))
+                                                   "libc-debug")))
+                     (union-build (assoc-ref %outputs "static")
+                                  (list (assoc-ref %build-inputs
+                                                   "libc-static")))))))
 
     (native-search-paths (package-native-search-paths gcc))
     (search-paths (package-search-paths gcc))
@@ -1038,7 +1041,7 @@ COREUTILS-FINAL vs. COREUTILS, etc."
 be installed in user profiles.  This includes GCC, as well as libc (headers
 and binaries, plus debugging symbols in the 'debug' output), and Binutils.")
     (home-page "https://gcc.gnu.org/";)
-    (outputs '("out" "debug"))
+    (outputs '("out" "debug" "static"))
 
     ;; The main raison d'être of this "meta-package" is (1) to conveniently
     ;; install everything that we need, and (2) to make sure ld-wrapper comes
@@ -1047,7 +1050,8 @@ and binaries, plus debugging symbols in the 'debug' 
output), and Binutils.")
               ("ld-wrapper" ,(car (assoc-ref %final-inputs "ld-wrapper")))
               ("binutils" ,binutils-final)
               ("libc" ,glibc-final)
-              ("libc-debug" ,glibc-final "debug")))))
+              ("libc-debug" ,glibc-final "debug")
+              ("libc-static" ,glibc-final "static")))))
 
 (define-public gcc-toolchain-4.8
   (make-gcc-toolchain gcc-4.8))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 95dc9746b..507a441f5 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -318,7 +318,7 @@ denoting a specific output of a package."
                  (propagated-inputs #$(map entry->gexp deps))
                  (search-paths #$(map search-path-specification->sexp
                                       search-paths))))
-      (($ <manifest-entry> name version output (? package? package)
+      (($ <manifest-entry> name version output package
                            (deps ...) (search-paths ...))
        #~(#$name #$version #$output
                  (ungexp package (or output "out"))
@@ -671,7 +671,9 @@ if not found."
             (return (find-among-inputs inputs)))))
         ((? string? item)
          (mlet %store-monad ((refs (references* item)))
-           (return (find-among-store-items refs)))))))
+           (return (find-among-store-items refs))))
+        (item
+         (return #f)))))
 
   (anym %store-monad
         entry-lookup-package (manifest-entries manifest)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 488638adc..f2c3d4729 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2017 Efraim Flashner <address@hidden>
 ;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2018 Konrad Hinsen <address@hidden>
@@ -216,11 +216,13 @@ the image."
       (('gnu rest ...) #t)
       (rest #f)))
 
+  (define defmod 'define-module)                  ;trick Geiser
+
   (define config
     ;; (guix config) module for consumption by (guix gcrypt).
     (scheme-file "gcrypt-config.scm"
                  #~(begin
-                     (define-module (guix config)
+                     (#$defmod (guix config)
                        #:export (%libgcrypt))
 
                      ;; XXX: Work around <http://bugs.gnu.org/15602>.
@@ -265,6 +267,63 @@ the image."
                     #:references-graphs `(("profile" ,profile))))
 

+;;;
+;;; Wrapped package.
+;;;
+
+(define (wrapped-package package)
+  (define runner
+    (local-file
+     (search-path %load-path "gnu/packages/aux-files/run-in-namespace.c")))
+
+  (define toolchain
+    (specification->package "gcc-toolchain"))
+
+  (define build
+    (with-imported-modules '((guix build utils))
+      #~(begin
+          (use-modules (guix build utils)
+                       (ice-9 match))
+
+          (define (strip-store-prefix file)
+            ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
+            ;; "/bin/foo".
+            (let* ((len  (string-length (%store-directory)))
+                   (base (string-drop file (+ 1 len))))
+              (match (string-index base #\/)
+                (#f    base)
+                (index (string-drop base index)))))
+
+          (define (build-wrapper program)
+            ;; Build a user-namespace wrapper for PROGRAM.
+            (format #t "building wrapper for '~a'...~%" program)
+            (copy-file #$runner "run.c")
+
+            (substitute* "run.c"
+              (("@WRAPPED_PROGRAM@") program)
+              (("@STORE_DIRECTORY@") (%store-directory)))
+
+            (let* ((base   (strip-store-prefix program))
+                   (result (string-append #$output "/" base)))
+              (mkdir-p (dirname result))
+              (invoke "gcc" "-static" "-Os" "-g0" "run.c"
+                      "-o" result)
+              (delete-file "run.c")))
+
+          (setvbuf (current-output-port) 'line)
+          (setenv "PATH" #+(file-append toolchain "/bin"))
+          (setenv "LIBRARY_PATH"
+                  (string-append #+toolchain "/lib:"
+                                 #+toolchain:static "/lib"))
+          (setenv "CPATH" #+(file-append toolchain "/include"))
+          (for-each build-wrapper
+                    (append (find-files #$(file-append package "/bin"))
+                            (find-files #$(file-append package "/sbin"))
+                            (find-files #$(file-append package 
"/libexec")))))))
+
+  (computed-file (package-full-name package) build))
+
+
 ;;;
 ;;; Command-line options.
 ;;;
@@ -408,9 +467,18 @@ Create a bundle of PACKAGE.\n"))
           (load* manifest-file user-module)))
        (else (packages->manifest packages)))))
 
+  (define (map-manifest-entries proc manifest)
+    (make-manifest
+     (map (lambda (entry)
+            (manifest-entry
+              (inherit entry)
+              (item (proc (manifest-entry-item entry)))))
+          (manifest-entries manifest))))
+
   (with-error-handling
     (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-           (manifest    (manifest-from-args opts))
+           (manifest    (map-manifest-entries wrapped-package
+                                              (manifest-from-args opts)))
            (pack-format (assoc-ref opts 'format))
            (name        (string-append (symbol->string pack-format)
                                        "-pack"))

This file has to be dropped as gnu/packages/aux-files/run-in-namespace.c:

#define _GNU_SOURCE
#include <stdlib.h>
#include <unistd.h>
#include <sched.h>
#include <sys/mount.h>
#include <errno.h>
#include <libgen.h>
#include <limits.h>
#include <string.h>
#include <assert.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <sys/wait.h>
#include <dirent.h>

static void
mkdir_p (const char *directory)
{
  if (strcmp (directory, "/") != 0)
    {
      char *parent = dirname (strdupa (directory));
      mkdir_p (parent);
      int err = mkdir (directory, 0700);
      if (err < 0 && errno != EEXIST)
        assert_perror (errno);
    }
}

static char *
concat (const char *directory, const char *file)
{
  char *result = malloc (strlen (directory) + 2
                         + strlen (file));
  assert (result != NULL);

  strcpy (result, directory);
  strcat (result, "/");
  strcat (result, file);
  return result;
}

/* Bind mount all the top-level entries in SOURCE to TARGET.  */
static void
bind_mount (const char *source, const char *target)
{
  DIR *stream = opendir (source);

  for (struct dirent *entry = readdir (stream);
       entry != NULL;
       entry = readdir (stream))
    {
      if (strcmp (entry->d_name, ".") == 0
          || strcmp (entry->d_name, "..") == 0
          || entry->d_type != DT_DIR)
        continue;

      char *new_entry = concat (target, entry->d_name);

      if (entry->d_type == DT_DIR)
        {
          /* Create the mount point.  */
          int err = mkdir (new_entry, 0700);
          if (err != 0)
            assert_perror (errno);
        }

      char *abs_source = concat (source, entry->d_name);

      int err = mount (abs_source, new_entry, "none",
                       MS_BIND | MS_REC | MS_RDONLY, NULL);
      if (err != 0)
        assert_perror (errno);

      free (new_entry);
      free (abs_source);
    }

  closedir (stream);
}

int
main (int argc, char *argv[])
{
  ssize_t size;
  char self[PATH_MAX];
  size = readlink ("/proc/self/exe", self, sizeof self - 1);
  assert (size > 0);

  /* SELF is something like "/home/ludo/.local/gnu/store/…-foo/bin/ls" and we
     want to extract "/home/ludo/.local/gnu/store".  */
  size_t index = strlen (self)
    - strlen ("@WRAPPED_PROGRAM@")
    + strlen ("@STORE_DIRECTORY@");
  char *store = strdup (self);
  store[index] = '\0';

  if (1) //(strcmp (store, "@STORE_DIRECTORY@") != 0)
    {
      /* Spawn @WRAPPED_PROGRAM@ in a separate namespace where STORE is
         bind-mounted in the right place.  */
      int err;

      err = unshare (CLONE_NEWNS | CLONE_NEWUSER);
      if (err < 0)
        assert_perror (errno);

      char *new_root = mkdtemp (strdup ("/tmp/guix-exec-XXXXXX"));
      bind_mount ("/", new_root);

      char *new_store = concat (new_root, "@STORE_DIRECTORY@");
      mkdir_p (new_store);
      err = mount (store, new_store, "none", MS_BIND | MS_REC | MS_RDONLY,
                   NULL);
      if (err < 0)
        assert_perror (errno);

      err = chroot (new_root);
      if (err < 0)
        assert_perror (errno);

      pid_t child = fork ();
      switch (child)
        {
        case 0:
          break;
        case -1:
          assert_perror (errno);
          break;
        default:
          {
            int status;
            waitpid (child, &status, 0);
            /* TODO: rm -rf NEW_ROOT */
            exit (status);
          }
        }
    }

  int err = execv ("@WRAPPED_PROGRAM@", argv);
  if (err < 0)
    assert_perror (errno);
}