From 9d3fb6c767913746340e8af4d967e386d2d0f1fd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 14 Apr 2015 23:19:01 +0200
Subject: [PATCH] install: Add a procedure to build a self-contained binary
 tarball.

Suggested by Pjotr Prins <pjotr.public12@thebird.nl>
at <http://lists.gnu.org/archive/html/guix-devel/2015-04/msg00229.html>.

* gnu/build/install.scm (populate-single-profile-directory): New procedure.
* gnu/system/install.scm (self-contained-tarball): New procedure.
* Makefile.am (guix-binary.%.tar.xz): New target.
---
 Makefile.am            |  7 +++++++
 gnu/build/install.scm  | 43 +++++++++++++++++++++++++++++++++++++++++-
 gnu/system/install.scm | 39 +++++++++++++++++++++++++++++++++++++-
 3 files changed, 87 insertions(+), 2 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 05ce9aa7b4..7bd689f6e1 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -342,6 +342,13 @@ dist_emacsui_DATA = emacs/guix-main.scm
 nodist_emacsui_DATA = emacs/guix-helper.scm
 include emacs.am
 
+# The self-contained tarball.
+guix-binary.%.tar.xz:
+	-GUIX_PACKAGE_PATH= \
+	$(top_builddir)/pre-inst-env "$(GUILE)"			\
+	  "$(top_srcdir)/build-aux/make-binary-tarball.scm" "$*" "$@"
+
+
 dist-hook: sync-descriptions gen-ChangeLog assert-no-store-file-names
 distcheck-hook: assert-binaries-available assert-final-inputs-self-contained
 
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 51895d58ec..f019fcb417 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -18,12 +18,14 @@
 
 (define-module (gnu build install)
   #:use-module (guix build utils)
+  #:use-module (guix build store-copy)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (install-grub
             populate-root-file-system
             reset-timestamps
-            register-closure))
+            register-closure
+            populate-single-profile-directory))
 
 ;;; Commentary:
 ;;;
@@ -157,4 +159,43 @@ by 'guix-register'.  As a side effect, this resets timestamps on store files."
     (unless (zero? status)
       (error "failed to register store items" closure))))
 
+(define* (populate-single-profile-directory directory
+                                            #:key profile closure)
+  "Populate DIRECTORY with a store containing PROFILE, whose closure is given
+in the file called CLOSURE (as generated by #:references-graphs.)  DIRECTORY
+is initialized to contain a single profile under /root pointing to PROFILE.
+This is used to create the self-contained Guix tarball."
+  (define (scope file)
+    (string-append directory "/" file))
+
+  (define %root-profile
+    "/var/guix/profiles/per-user/root")
+
+  (define (mkdir-p* dir)
+    (mkdir-p (scope dir)))
+
+  (define (symlink* old new)
+    (symlink old (scope new)))
+
+  ;; Populate the store.
+  (populate-store (list closure) directory)
+  (register-closure (canonicalize-path directory) closure)
+
+  ;; XXX: 'guix-register' registers profiles as GC roots but the symlink
+  ;; target uses $TMPDIR.  Fix that.
+  (delete-file (scope "/var/guix/gcroots/profiles"))
+  (symlink* "/var/guix/profiles"
+            "/var/guix/gcroots/profiles")
+
+  ;; Make root's profile, which makes it a GC root.
+  (mkdir-p* %root-profile)
+  (symlink* profile
+            (string-append %root-profile "/guix-profile-1-link"))
+  (symlink* (string-append %root-profile "/guix-profile-1-link")
+            (string-append %root-profile "/guix-profile"))
+
+  (mkdir-p* "/root")
+  (symlink* (string-append %root-profile "/guix-profile")
+            "/root/.guix-profile"))
+
 ;;; install.scm ends here
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 2e7e4eafad..2fd35e8c48 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -22,6 +22,7 @@
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module ((guix store) #:select (%store-prefix))
+  #:use-module (guix profiles)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages cryptsetup)
@@ -30,7 +31,8 @@
   #:use-module (gnu packages grub)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages compression)
-  #:export (installation-os))
+  #:export (self-contained-tarball
+            installation-os))
 
 ;;; Commentary:
 ;;;
@@ -39,6 +41,41 @@
 ;;;
 ;;; Code:
 
+
+(define* (self-contained-tarball #:key (guix guix))
+  "Return a self-contained tarball containing a store initialized with the
+closure of GUIX.  The tarball contains /gnu/store, /var/guix, and a profile
+under /root/.guix-profile where GUIX is installed."
+  (mlet %store-monad ((profile (profile-derivation
+                                (manifest
+                                 (list (package->manifest-entry guix))))))
+    (define build
+      #~(begin
+          (use-modules (guix build utils)
+                       (gnu build install))
+
+          (define %root "root")
+
+          (setenv "PATH"
+                  (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin"))
+
+          (populate-single-profile-directory %root
+                                             #:profile #$profile
+                                             #:closure "profile")
+
+          ;; Create the tarball.  Use GNU format so there's no file name
+          ;; length limitation.
+          (with-directory-excursion %root
+            (zero? (system* "tar" "--xz" "--format=gnu"
+                            "-cvf" #$output ".")))))
+
+    (gexp->derivation "guix-tarball.tar.xz" build
+                      #:references-graphs `(("profile" ,profile))
+                      #:modules '((guix build utils)
+                                  (guix build store-copy)
+                                  (gnu build install)))))
+
+
 (define (log-to-info)
   "Return a script that spawns the Info reader on the right section of the
 manual."