gnu: emacs: Remove *.elc and autoloads from the tarball.

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

diff --git a/gnu/services.scm b/gnu/services.scm
index 0e1c74b..9268c51 100644 (file)
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -63,6 +64,7 @@
 
             system-service-type
             boot-service-type
+            cleanup-service-type
             activation-service-type
             activation-service->script
             %linux-bare-metal-service
@@ -85,8 +87,8 @@
 ;;; A service type describe how its instances extend instances of other
 ;;; service types.  For instance, some services extend the instance of
 ;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
-;;; others extend DMD-ROOT-SERVICE-TYPE by passing it instances of
-;;; <dmd-service>.
+;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
+;;; <shepherd-service>.
 ;;;
 ;;; When applicable, the service type defines how it can itself be extended,
 ;;; by providing one procedure to compose extensions, and one procedure to
@@ -152,8 +154,8 @@
 
 (define-syntax modify-services
   (syntax-rules ()
-    "Modify the services listed in SERVICES according to CLAUSES.  Each clause
-must have the form:
+    "Modify the services listed in SERVICES according to CLAUSES and return
+the resulting list of services.  Each clause must have the form:
 
   (TYPE VARIABLE => BODY)
 
@@ -208,23 +210,8 @@ containing the given entries."
 (define (compute-boot-script _ mexps)
   (mlet %store-monad ((gexps (sequence %store-monad mexps)))
     (gexp->file "boot"
-                #~(begin
-                    (use-modules (guix build utils))
-
-                    ;; Clean out /tmp and /var/run.
-                    ;;
-                    ;; XXX This needs to happen before service activations, so
-                    ;; it has to be here, but this also implicitly assumes
-                    ;; that /tmp and /var/run are on the root partition.
-                    (false-if-exception (delete-file-recursively "/tmp"))
-                    (false-if-exception (delete-file-recursively "/var/run"))
-                    (false-if-exception (mkdir "/tmp"))
-                    (false-if-exception (chmod "/tmp" #o1777))
-                    (false-if-exception (mkdir "/var/run"))
-                    (false-if-exception (chmod "/var/run" #o755))
-
-                    ;; Activate the system and spawn dmd.
-                    #$@gexps))))
+                ;; Clean up and activate the system, then spawn shepherd.
+                #~(begin #$@gexps))))
 
 (define (boot-script-entry mboot)
   "Return, as a monadic value, an entry for the boot script in the system
@@ -247,6 +234,53 @@ directory."
   ;; The service that produces the boot script.
   (service boot-service-type #t))
 
+(define (cleanup-gexp _)
+  "Return as a monadic value a gexp to clean up /tmp and similar places upon
+boot."
+  (define %modules
+    '((guix build utils)))
+
+  (mlet %store-monad ((modules  (imported-modules %modules))
+                      (compiled (compiled-modules %modules)))
+    (return #~(begin
+                (eval-when (expand load eval)
+                  ;; Make sure 'use-modules' below succeeds.
+                  (set! %load-path (cons #$modules %load-path))
+                  (set! %load-compiled-path
+                    (cons #$compiled %load-compiled-path)))
+
+                (use-modules (guix build utils))
+
+                ;; Clean out /tmp and /var/run.
+                ;;
+                ;; XXX This needs to happen before service activations, so it
+                ;; has to be here, but this also implicitly assumes that /tmp
+                ;; and /var/run are on the root partition.
+                (letrec-syntax ((fail-safe (syntax-rules ()
+                                             ((_ exp rest ...)
+                                              (begin
+                                                (catch 'system-error
+                                                  (lambda () exp)
+                                                  (const #f))
+                                                (fail-safe rest ...)))
+                                             ((_)
+                                              #t))))
+                  ;; Ignore I/O errors so the system can boot.
+                  (fail-safe
+                   (delete-file-recursively "/tmp")
+                   (delete-file-recursively "/var/run")
+                   (mkdir "/tmp")
+                   (chmod "/tmp" #o1777)
+                   (mkdir "/var/run")
+                   (chmod "/var/run" #o755)))))))
+
+(define cleanup-service-type
+  ;; Service that cleans things up in /tmp and similar.
+  (service-type (name 'cleanup)
+                (extensions
+                 (list (service-extension boot-service-type
+                                          cleanup-gexp)))))
+
 (define* (file-union name files)                  ;FIXME: Factorize.
   "Return a <computed-file> that builds a directory containing all of FILES.
 Each item in FILES must be a list where the first element is the file name to
@@ -258,7 +292,12 @@ file."
                      (chdir #$output)
                      #$@(map (match-lambda
                                ((target source)
-                                #~(symlink #$source #$target)))
+                                #~(begin
+                                    ;; Stat the source to abort early if it
+                                    ;; does not exist.
+                                    (stat #$source)
+
+                                    (symlink #$source #$target))))
                              files))))
 
 (define (directory-union name things)
@@ -288,6 +327,7 @@ ACTIVATION-SCRIPT-TYPE."
       (gnu build file-systems)
       (guix build utils)
       (guix build syscalls)
+      (guix build bournish)
       (guix elf)))
 
   (define (service-activations)
@@ -419,8 +459,8 @@ FILES must be a list of name/file-like object pairs."
 (define (packages->profile-entry packages)
   "Return a system entry for the profile containing PACKAGES."
   (mlet %store-monad ((profile (profile-derivation
-                                (manifest (map package->manifest-entry
-                                               (delete-duplicates packages eq?))))))
+                                (packages->manifest
+                                 (delete-duplicates packages eq?)))))
     (return `(("profile" ,profile)))))
 
 (define profile-service-type