01/01: vm: Auto-detect if inputs should be registered.

[guix-commits]

apteryx pushed a commit to branch master
in repository guix.

commit d03de6be0aa2e2889314b5ed9a8867375363d79f
Author: Maxim Cournoyer <address@hidden>
Date:   Tue Apr 16 17:15:02 2019 -0400

    vm: Auto-detect if inputs should be registered.
    
    The default value of the argument REGISTER-CLOSURE? of the ISO9660-IMAGE,
    QEMU-IMAGE and SYSTEM-DOCKER-IMAGE procedures can be computed automatically,
    since the operating-system definition is available in its context.  When the
    operating-system definition does not contain the GUIX-SERVICE-TYPE, do not
    register the closure in the database of Guix, as it takes time and doesn't
    serve a purpose.
    
    * gnu/system/vm.scm (has-guix-service-type): Add predicate.
    (iso9660-image)[register-closures?]: Use it to compute the argument's 
default
    value.
    (qemu-image)[register-closures?]: Likewise, and update docstring.
    (system-docker-image)[register-closures?]: Likewise.
    (system-disk-image): Do not explicit a value for the REGISTER-CLOSURES?
    argument of the ISO9660-IMAGE and QEMU-IMAGE procedure calls, so that its
    default value is used instead.
    * guix/scripts/system.scm (system-derivation-for-action): Do not explicit a
    value for the REGISTER-CLOSURES? argument of the SYSTEM-DOCKER-IMAGE
    procedure call, so that its default value is used instead.
---
 gnu/system/vm.scm       | 30 ++++++++++++++++++------------
 guix/scripts/system.scm |  2 +-
 2 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 124abd0..2eeb700 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -64,6 +64,7 @@
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
+  #:use-module (gnu services base)
   #:use-module (gnu system uuid)
 
   #:use-module (srfi srfi-1)
@@ -249,6 +250,12 @@ made available under the /xchg CIFS share."
                       #:guile-for-build guile-for-build
                       #:references-graphs references-graphs)))
 
+(define (has-guix-service-type? os)
+  "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
+  (not (not (find (lambda (service)
+                     (eq? (service-kind service) guix-service-type))
+                   (operating-system-services os)))))
+
 (define* (iso9660-image #:key
                         (name "iso9660-image")
                         file-system-label
@@ -258,7 +265,7 @@ made available under the /xchg CIFS share."
                         os
                         bootcfg-drv
                         bootloader
-                        register-closures?
+                        (register-closures? (has-guix-service-type? os))
                         (inputs '()))
   "Return a bootable, stand-alone iso9660 image.
 
@@ -343,7 +350,7 @@ INPUTS is a list of inputs (as for packages)."
                      os
                      bootcfg-drv
                      bootloader
-                     (register-closures? #t)
+                     (register-closures? (has-guix-service-type? os))
                      (inputs '())
                      copy-inputs?)
   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
@@ -359,7 +366,9 @@ file (GRUB-CONFIGURATION must be the name of a file in the 
VM.)
 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
-the image."
+the image.  By default, REGISTER-CLOSURES? is set to true only if a service of
+type GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -474,14 +483,13 @@ the image."
 (define* (system-docker-image os
                               #:key
                               (name "guixsd-docker-image")
-                              register-closures?)
+                              (register-closures? (has-guix-service-type? os)))
   "Build a docker image.  OS is the desired <operating-system>.  NAME is the
-base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
-register the closure of OS with Guix in the resulting Docker image.  This only
-makes sense when you want to build a Guix System Docker image that has Guix
-installed inside of it.  If you don't need Guix (e.g., your Docker
-image just contains a web server that is started by the Shepherd), then you
-should set REGISTER-CLOSURES? to #f."
+base name to use for the output file.  When REGISTER-CLOSURES? is true,
+register the closure of OS with Guix in the resulting Docker image.  By
+default, REGISTER-CLOSURES? is set to true only if a service of type
+GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -678,7 +686,6 @@ to USB sticks meant to be read-only."
                        #:file-system-label root-label
                        #:file-system-uuid uuid
                        #:os os
-                       #:register-closures? #t
                        #:bootcfg-drv bootcfg
                        #:bootloader (bootloader-configuration-bootloader
                                      (operating-system-bootloader os))
@@ -695,7 +702,6 @@ to USB sticks meant to be read-only."
                     #:file-system-label root-label
                     #:file-system-uuid uuid
                     #:copy-inputs? #t
-                    #:register-closures? #t
                     #:inputs `(("system" ,os)
                                ("bootcfg" ,bootcfg))))))
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index cf4418f..8434d1e 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -786,7 +786,7 @@ checking this by themselves in their 'check' procedure."
                         #:disk-image-size image-size
                         #:file-system-type file-system-type))
     ((docker-image)
-     (system-docker-image os #:register-closures? #t))))
+     (system-docker-image os))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."