WIP: bees service

[jackhill/guix/guix.git] / gnu / services.scm

diff --git a/gnu/services.scm b/gnu/services.scm
index 11ba21e..e7da0a0 100644 (file)
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -109,7 +110,11 @@
 
             %boot-service
             %activation-service
-            etc-service))
+            etc-service)
+  #:re-export (;; Note: Re-export 'delete' to allow for proper syntax matching
+               ;; in 'modify-services' forms.  See
+               ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
+               delete))
 
 ;;; Comment:
 ;;;
@@ -279,7 +284,11 @@ singleton service type NAME, of which the returned service is an instance."
     (service type value)))
 
 (define-syntax %modify-service
-  (syntax-rules (=>)
+  (syntax-rules (=> delete)
+    ((_ svc (delete kind) clauses ...)
+     (if (eq? (service-kind svc) kind)
+         #f
+         (%modify-service svc clauses ...)))
     ((_ service)
      service)
     ((_ svc (kind param => exp ...) clauses ...)
@@ -309,16 +318,18 @@ TYPE.  Consider this example:
     (mingetty-service-type config =>
                            (mingetty-configuration
                             (inherit config)
-                            (motd (plain-file \"motd\" \"Hi there!\")))))
+                            (motd (plain-file \"motd\" \"Hi there!\"))))
+    (delete udev-service-type))
 
 It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
-all the MINGETTY-SERVICE-TYPE instances.
+all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the
+UDEV-SERVICE-TYPE.
 
-This is a shorthand for (map (lambda (svc) ...) %base-services)."
+This is a shorthand for (filter-map (lambda (svc) ...) %base-services)."
     ((_ services clauses ...)
-     (map (lambda (service)
-            (%modify-service service clauses ...))
-          services))))
+     (filter-map (lambda (service)
+                   (%modify-service service clauses ...))
+                 services))))
 
 \f
 ;;;
@@ -461,7 +472,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
@@ -612,13 +628,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
@@ -783,7 +807,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?)))))))))