Load new Guix revisions within a container

Use some experimental functionality to run the inferior repl in a
container. This provides some isolation.

1 files changed, 85 insertions, 27 deletions

diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 783b74f..8c2e3a9 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -1,4 +1,5 @@
 (define-module (guix-data-service jobs load-new-guix-revision)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:use-module (squee)
   #:use-module (guix monads)
@@ -6,6 +7,7 @@
   #:use-module (guix channels)
   #:use-module (guix inferior)
   #:use-module (guix profiles)
+  #:use-module (guix packages)
   #:use-module (guix derivations)
   #:use-module (guix build utils)
   #:use-module (guix-data-service model package)
@@ -29,39 +31,92 @@
     (inferior-packages->package-ids
      conn packages packages-metadata-ids packages-derivation-ids)))
 
+(define (guix-store-path store)
+  (let* ((guix-package (@ (gnu packages package-management)
+                          guix))
+         (derivation (package-derivation store guix-package)))
+    (build-derivations store (list derivation))
+    (derivation->output-path derivation)))
+
+(define (nss-certs-store-path store)
+  (let* ((nss-certs-package (@ (gnu packages certs)
+                               nss-certs))
+         (derivation (package-derivation store nss-certs-package)))
+    (build-derivations store (list derivation))
+    (derivation->output-path derivation)))
+
+(define (channel->derivation-file-name store channel)
+  (let ((inferior
+         (open-inferior/container
+          store
+          (guix-store-path store)
+          #:extra-shared-directories
+          '("/gnu/store")
+          #:extra-environment-variables
+          (list (string-append
+                 "SSL_CERT_DIR=" (nss-certs-store-path store))))))
+
+    ;; Create /etc/pass, as %known-shorthand-profiles in (guix
+    ;; profiles) tries to read from this file. Because the environment
+    ;; is cleaned in build-self.scm, xdg-directory in (guix utils)
+    ;; falls back to accessing /etc/passwd.
+    (inferior-eval
+     '(begin
+        (mkdir "/etc")
+        (call-with-output-file "/etc/passwd"
+          (lambda (port)
+            (display "root:x:0:0::/root:/bin/bash" port))))
+     inferior)
+
+    (let ((channel-instance
+           (first
+            (latest-channel-instances store
+                                      (list channel)))))
+      (inferior-eval '(use-modules (guix channels)
+                                   (guix profiles))
+                     inferior)
+      (inferior-eval '(define channel-instance
+                        (@@ (guix channels) channel-instance))
+                     inferior)
+
+      (inferior-eval-with-store
+       inferior
+       store
+       `(lambda (store)
+          (let ((instances
+                 (list
+                  (channel-instance
+                   (channel (name ',(channel-name channel))
+                            (url    ,(channel-url channel))
+                            (branch ,(channel-branch channel))
+                            (commit ,(channel-commit channel)))
+                   ,(channel-instance-commit channel-instance)
+                   ,(channel-instance-checkout channel-instance)))))
+            (run-with-store store
+              (mlet* %store-monad ((manifest (channel-instances->manifest instances))
+                                   (derv (profile-derivation manifest)))
+                (mbegin %store-monad
+                  (return (derivation-file-name derv)))))))))))
+
 (define (channel->manifest-store-item store channel)
-  (let ((inferior (open-inferior
-                   (dirname
-                    (dirname
-                     (which "guix"))))))
-    (inferior-eval '(use-modules (guix channels)
-                                 (guix profiles))
-                   inferior)
-    (inferior-eval-with-store
-     inferior
-     store
-     `(lambda (store)
-        (let ((instances (latest-channel-instances
-                          store
-                          (list (channel (name   ',(channel-name channel))
-                                         (url    ,(channel-url channel))
-                                         (branch ,(channel-branch channel))
-                                         (commit ,(channel-commit channel)))))))
-          (run-with-store store
-            (mlet* %store-monad ((manifest (channel-instances->manifest instances))
-                                 (derv (profile-derivation manifest)))
-              (mbegin %store-monad
-                (built-derivations (list derv))
-                (return (derivation->output-path derv))))))))))
+  (let* ((manifest-store-item-derivation-file-name
+          (channel->derivation-file-name store channel))
+         (derivation
+          (read-derivation-from-file manifest-store-item-derivation-file-name)))
+    (build-derivations store (list derivation))
+    (derivation->output-path derivation)))
 
 (define (channel->guix-store-item store channel)
   (dirname
    (readlink
-    (string-append (channel->manifest-store-item store channel)
+    (string-append (channel->manifest-store-item store
+                                                 channel)
                    "/bin"))))
 
 (define (extract-information-from store conn url commit store_path)
-  (let ((inf (open-inferior store_path)))
+  (let ((inf (open-inferior/container store store_path
+                                      #:extra-shared-directories
+                                      '("/gnu/store"))))
     (inferior-eval '(use-modules (guix grafts)) inf)
     (inferior-eval '(%graft? #f) inf)
 
@@ -70,9 +125,12 @@
 
       (let ((guix-revision-id
              (insert-guix-revision conn url commit store_path)))
-        (insert-guix-revision-packages conn guix-revision-id package-ids)))
+        (insert-guix-revision-packages conn guix-revision-id package-ids))
+
+      (exec-query conn "COMMIT")
 
-    (exec-query conn "COMMIT")
+      (simple-format
+       #t "Successfully loaded ~A packages\n" (length package-ids)))
 
     (close-inferior inf)))