;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
#:use-module (guix profiles)
#:use-module (guix discovery)
#:use-module (guix combinators)
+ #:use-module (guix channels)
+ #:use-module (guix describe)
#:use-module (guix sets)
#:use-module (guix ui)
#:use-module ((guix utils) #:select (source-properties->location))
#:use-module (srfi srfi-35)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
+ #:autoload (ice-9 pretty-print) (pretty-print)
#:export (service-extension
service-extension?
service-extension-target
ambiguous-target-service-error-target-type
system-service-type
+ provenance-service-type
boot-service-type
cleanup-service-type
activation-service-type
turn refers to everything the operating system needs: its kernel, initrd,
system profile, boot script, and so on.")))
-(define (compute-boot-script _ mexps)
- ;; Reverse MEXPS so that extensions appear in the boot script in the right
+(define (compute-boot-script _ gexps)
+ ;; Reverse GEXPS so that extensions appear in the boot script in the right
;; order. That is, user extensions would come first, and extensions added
;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
;; last.
- (mlet %store-monad ((gexps (sequence %store-monad (reverse mexps))))
- (gexp->file "boot"
- ;; Clean up and activate the system, then spawn shepherd.
- #~(begin #$@gexps))))
+ (gexp->file "boot"
+ ;; Clean up and activate the system, then spawn shepherd.
+ #~(begin #$@(reverse gexps))))
(define (boot-script-entry mboot)
"Return, as a monadic value, an entry for the boot script in the system
(return `(("boot" ,boot)))))
(define boot-service-type
- ;; The service of this type is extended by being passed gexps as monadic
- ;; values. It aggregates them in a single script, as a monadic value, which
- ;; becomes its 'parameters'. It is the only service that extends nothing.
+ ;; The service of this type is extended by being passed gexps. It
+ ;; aggregates them in a single script, as a monadic value, which becomes its
+ ;; value.
(service-type (name 'boot)
(extensions
(list (service-extension system-service-type
;; The service that produces the boot script.
(service boot-service-type #t))
+\f
+;;;
+;;; Provenance tracking.
+;;;
+
+(define (object->pretty-string obj)
+ "Like 'object->string', but using 'pretty-print'."
+ (call-with-output-string
+ (lambda (port)
+ (pretty-print obj port))))
+
+(define (channel->code channel)
+ "Return code to build CHANNEL, ready to be dropped in a 'channels.scm'
+file."
+ `(channel (name ',(channel-name channel))
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,(channel-commit channel))))
+
+(define (channel->sexp channel)
+ "Return an sexp describing CHANNEL. The sexp is _not_ code and is meant to
+be parsed by tools; it's potentially more future-proof than code."
+ `(channel (name ,(channel-name channel))
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,(channel-commit channel))))
+
+(define (provenance-file channels config-file)
+ "Return a 'provenance' file describing CHANNELS, a list of channels, and
+CONFIG-FILE, which can be either #f or a <local-file> containing the OS
+configuration being used."
+ (scheme-file "provenance"
+ #~(provenance
+ (version 0)
+ (channels #+@(if channels
+ (map channel->sexp channels)
+ '()))
+ (configuration-file #+config-file))))
+
+(define (provenance-entry config-file)
+ "Return system entries describing the operating system provenance: the
+channels in use and CONFIG-FILE, if it is true."
+ (define profile
+ (current-profile))
+
+ (define channels
+ (and=> profile profile-channels))
+
+ (mbegin %store-monad
+ (let ((config-file (cond ((string? config-file)
+ (local-file config-file "configuration.scm"))
+ ((not config-file)
+ #f)
+ (else
+ config-file))))
+ (return `(("provenance" ,(provenance-file channels config-file))
+ ,@(if channels
+ `(("channels.scm"
+ ,(plain-file "channels.scm"
+ (object->pretty-string
+ `(list
+ ,@(map channel->code channels))))))
+ '())
+ ,@(if config-file
+ `(("configuration.scm" ,config-file))
+ '()))))))
+
+(define provenance-service-type
+ (service-type (name 'provenance)
+ (extensions
+ (list (service-extension system-service-type
+ provenance-entry)))
+ (default-value #f) ;the OS config file
+ (description
+ "Store provenance information about the system in the system
+itself: the channels used when building the system, and its configuration
+file, when available.")))
+
+\f
+;;;
+;;; Cleanup.
+;;;
+
(define (cleanup-gexp _)
- "Return as a monadic value a gexp to clean up /tmp and similar places upon
-boot."
- (with-monad %store-monad
- (with-imported-modules '((guix build utils))
- (return #~(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.
- (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
- ;; Remove stale Shadow lock files as they would lead to
- ;; failures of 'useradd' & co.
- (delete-file "/etc/group.lock")
- (delete-file "/etc/passwd.lock")
- (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
-
- ;; Force file names to be decoded as UTF-8. See
- ;; <https://bugs.gnu.org/26353>.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (setlocale LC_CTYPE "en_US.utf8")
- (delete-file-recursively "/tmp")
- (delete-file-recursively "/var/run")
-
- (mkdir "/tmp")
- (chmod "/tmp" #o1777)
- (mkdir "/var/run")
- (chmod "/var/run" #o755)
- (delete-file-recursively "/run/udev/watch.old"))))))))
+ "Return a gexp to clean up /tmp and similar places upon boot."
+ (with-imported-modules '((guix build utils))
+ #~(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.
+ (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
+ ;; Remove stale Shadow lock files as they would lead to
+ ;; failures of 'useradd' & co.
+ (delete-file "/etc/group.lock")
+ (delete-file "/etc/passwd.lock")
+ (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
+
+ ;; Force file names to be decoded as UTF-8. See
+ ;; <https://bugs.gnu.org/26353>.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_CTYPE "en_US.utf8")
+ (delete-file-recursively "/tmp")
+ (delete-file-recursively "/var/run")
+
+ (mkdir "/tmp")
+ (chmod "/tmp" #o1777)
+ (mkdir "/var/run")
+ (chmod "/var/run" #o755)
+ (delete-file-recursively "/run/udev/watch.old"))))))
(define cleanup-service-type
;; Service that cleans things up in /tmp and similar.
(define (activation-script gexps)
"Return the system's activation script, which evaluates GEXPS."
- (define (service-activations)
- ;; Return the activation scripts for SERVICES.
- (mapm %store-monad
- (cut gexp->file "activate-service" <>)
- gexps))
-
- (mlet* %store-monad ((actions (service-activations)))
- (gexp->file "activate"
+ (define actions
+ (map (cut program-file "activate-service.scm" <>) gexps))
+
+ (program-file "activate.scm"
(with-imported-modules (source-module-closure
'((gnu build activation)
(guix build utils)))
;; Run the services' activation snippets.
;; TODO: Use 'load-compiled'.
- (for-each primitive-load '#$actions))))))
+ (for-each primitive-load '#$actions)))))
(define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS."
- (mlet %store-monad ((script (activation-script gexps)))
- (return #~(primitive-load #$script))))
+ #~(primitive-load #$(activation-script gexps)))
(define (second-argument a b) b)
(extend append)
(description
"Register garbage-collector roots---i.e., store items that
-will not be reclaimed by the garbage collector.")))
+will not be reclaimed by the garbage collector.")
+ (default-value '())))
\f
;;;
instances
(service-type-extensions (service-kind svc))))
- (let ((instances (fold (lambda (service result)
- (vhash-consq (service-kind service) service
- result))
- vlist-null services)))
- (fold2 adjust-service-list
- services instances
- services)))
+ (let loop ((services services))
+ (define instances
+ (fold (lambda (service result)
+ (vhash-consq (service-kind service) service
+ result))
+ vlist-null services))
+
+ (define adjusted
+ (fold2 adjust-service-list
+ services instances
+ services))
+
+ ;; If we instantiated services, they might in turn depend on missing
+ ;; services. Loop until we've reached fixed point.
+ (if (= (length adjusted) (vlist-length instances))
+ adjusted
+ (loop adjusted))))
(define* (fold-services services
#:key (target-type system-service-type))
(eq? (service-kind service) target-type))
services)
((sink)
- (let loop ((sink sink))
- (let* ((dependents (map loop (dependents sink)))
- (extensions (map (apply-extension sink) dependents))
- (extend (service-type-extend (service-kind sink)))
- (compose (service-type-compose (service-kind sink)))
- (params (service-value sink)))
- ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a
- ;; different type than the elements of EXTENSIONS.
- (if extend
- (service (service-kind sink)
- (extend params (compose extensions)))
- sink))))
+ ;; Use the state monad to keep track of already-visited services in the
+ ;; graph and to memoize their value once folded.
+ (run-with-state
+ (let loop ((sink sink))
+ (mlet %state-monad ((visited (current-state)))
+ (match (vhash-assq sink visited)
+ (#f
+ (mlet* %state-monad
+ ((dependents (mapm %state-monad loop (dependents sink)))
+ (visited (current-state))
+ (extensions -> (map (apply-extension sink) dependents))
+ (extend -> (service-type-extend (service-kind sink)))
+ (compose -> (service-type-compose (service-kind sink)))
+ (params -> (service-value sink))
+ (service
+ ->
+ ;; Distinguish COMPOSE and EXTEND because PARAMS typically
+ ;; has a different type than the elements of EXTENSIONS.
+ (if extend
+ (service (service-kind sink)
+ (extend params (compose extensions)))
+ sink)))
+ (mbegin %state-monad
+ (set-current-state (vhash-consq sink service visited))
+ (return service))))
+ ((_ . service) ;SINK was already visited
+ (return service)))))
+ vlist-null))
(()
(raise
(condition (&missing-target-service-error
HCoop / jackhill / guix / guix.git / blobdiff