X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/b91a73a6a4a419ffd53c41916d8acf3232b10eea..12580eb435b4a43be76ad3b900657ec67a70fee7:/gnu/services.scm

diff --git a/gnu/services.scm b/gnu/services.scm
index 6509a9014e..ddd1bac30c 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -30,7 +30,7 @@
   #:use-module (guix describe)
   #:use-module (guix sets)
   #:use-module (guix ui)
-  #:use-module ((guix utils) #:select (source-properties->location))
+  #:use-module (guix diagnostics)
   #:autoload   (guix openpgp) (openpgp-format-fingerprint)
   #:use-module (guix modules)
   #:use-module (gnu packages base)
@@ -89,6 +89,7 @@
 
             system-service-type
             provenance-service-type
+            sexp->system-provenance
             system-provenance
             boot-service-type
             cleanup-service-type
@@ -242,13 +243,13 @@ TYPE does not have a default value, an error is raised."
     (if (eq? default &no-default-value)
         (let ((location (source-properties->location location)))
           (raise
-           (condition
-            (&missing-value-service-error (type type) (location location))
-            (&message
-             (message (format #f (G_ "~a: no value specified \
+           (make-compound-condition
+            (condition
+             (&missing-value-service-error (type type) (location location)))
+            (formatted-message (G_ "~a: no value specified \
 for service of type '~a'")
-                              (location->string location)
-                              (service-type-name type)))))))
+                               (location->string location)
+                               (service-type-name type)))))
         (service type default))))
 
 (define-condition-type &service-error &error
@@ -460,7 +461,12 @@ channels in use and CONFIG-FILE, if it is true."
 
   (mbegin %store-monad
     (let ((config-file (cond ((string? config-file)
-                              (local-file config-file "configuration.scm"))
+                              ;; CONFIG-FILE has been passed typically via
+                              ;; 'guix system reconfigure CONFIG-FILE' so we
+                              ;; can assume it's valid: tell 'local-file' to
+                              ;; not emit a warning.
+                              (local-file (assume-valid-file-name config-file)
+                                          "configuration.scm"))
                              ((not config-file)
                               #f)
                              (else
@@ -488,6 +494,19 @@ channels in use and CONFIG-FILE, if it is true."
 itself: the channels used when building the system, and its configuration
 file, when available.")))
 
+(define (sexp->system-provenance sexp)
+  "Parse SEXP, an s-expression read from /run/current-system/provenance or
+similar, and return two values: the list of channels listed therein, and the
+OS configuration file or #f."
+  (match sexp
+    (('provenance ('version 0)
+                  ('channels channels ...)
+                  ('configuration-file config-file))
+     (values (map sexp->channel channels)
+             config-file))
+    (_
+     (values '() #f))))
+
 (define (system-provenance system)
   "Given SYSTEM, the file name of a system generation, return two values: the
 list of channels SYSTEM is built from, and its configuration file.  If that
@@ -495,15 +514,9 @@ information is missing, return the empty list (for channels) and possibly
 #false (for the configuration file)."
   (catch 'system-error
     (lambda ()
-      (match (call-with-input-file (string-append system "/provenance")
-               read)
-        (('provenance ('version 0)
-                      ('channels channels ...)
-                      ('configuration-file config-file))
-         (values (map sexp->channel channels)
-                 config-file))
-        (_
-         (values '() #f))))
+      (sexp->system-provenance
+       (call-with-input-file (string-append system "/provenance")
+         read)))
     (lambda _
       (values '() #f))))
 
@@ -604,13 +617,21 @@ ACTIVATION-SCRIPT-TYPE."
   "Return a gexp that runs the activation script containing GEXPS."
   #~(primitive-load #$(activation-script gexps)))
 
+(define (activation-profile-entry gexps)
+  "Return, as a monadic value, an entry for the activation script in the
+system directory."
+  (mlet %store-monad ((activate (lower-object (activation-script gexps))))
+    (return `(("activate" ,activate)))))
+
 (define (second-argument a b) b)
 
 (define activation-service-type
   (service-type (name 'activate)
                 (extensions
                  (list (service-extension boot-service-type
-                                          gexps->activation-gexp)))
+                                          gexps->activation-gexp)
+                       (service-extension system-service-type
+                                          activation-profile-entry)))
                 (compose identity)
                 (extend second-argument)
                 (description
@@ -725,10 +746,8 @@ and FILE could be \"/usr/bin/env\"."
         (() #t)
         (((file _) rest ...)
          (when (set-contains? seen file)
-           (raise (condition
-                   (&message
-                    (message (format #f (G_ "duplicate '~a' entry for /etc")
-                                     file))))))
+           (raise (formatted-message (G_ "duplicate '~a' entry for /etc")
+                                     file)))
          (loop rest (set-insert file seen))))))
 
   ;; Detect duplicates early instead of letting them through, eventually
@@ -777,7 +796,13 @@ executables, making them setuid-root.")))
 
 (define (packages->profile-entry packages)
   "Return a system entry for the profile containing PACKAGES."
-  (with-monad %store-monad
+  ;; XXX: 'mlet' is needed here for one reason: to get the proper
+  ;; '%current-target' and '%current-target-system' bindings when
+  ;; 'packages->manifest' is called, and thus when the 'package-inputs'
+  ;; etc. procedures are called on PACKAGES.  That way, conditionals in those
+  ;; inputs see the "correct" value of these two parameters.  See
+  ;; <https://issues.guix.gnu.org/44952>.
+  (mlet %store-monad ((_ (current-target-system)))
     (return `(("profile" ,(profile
                            (content (packages->manifest
                                      (delete-duplicates packages eq?)))))))))
@@ -1000,12 +1025,12 @@ TARGET-TYPE; return the root service adjusted accordingly."
        vlist-null))
     (()
      (raise
-      (condition (&missing-target-service-error
-                  (service #f)
-                  (target-type target-type))
-                 (&message
-                  (message (format #f (G_ "service of type '~a' not found")
-                                   (service-type-name target-type)))))))
+      (make-compound-condition
+       (condition (&missing-target-service-error
+                   (service #f)
+                   (target-type target-type)))
+       (formatted-message (G_ "service of type '~a' not found")
+                          (service-type-name target-type)))))
     (x
      (raise
       (condition (&ambiguous-target-service-error