;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
#: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)
#:use-module (gnu packages bash)
+ #:use-module (gnu packages hurd)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
system-service-type
provenance-service-type
+ sexp->system-provenance
+ system-provenance
boot-service-type
cleanup-service-type
activation-service-type
activation-service->script
%linux-bare-metal-service
+ %hurd-rc-script
+ %hurd-startup-service
special-files-service-type
extra-special-file
etc-service-type
%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:
;;;
(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
(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 ...)
(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
;;;
;;; Core services.
;;;
-(define (system-derivation mentries mextensions)
+(define (system-derivation entries mextensions)
"Return as a monadic value the derivation of the 'system' directory
containing the given entries."
- (mlet %store-monad ((entries mentries)
- (extensions (mapm/accumulate-builds identity
+ (mlet %store-monad ((extensions (mapm/accumulate-builds identity
mextensions)))
(lower-object
(file-union "system"
(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))))
+ ;; Since the 'introduction' field is backward-incompatible, and since it's
+ ;; optional when using the "official" 'guix channel, include it if and only
+ ;; if we're referring to a different channel.
+ (let ((intro (and (not (equal? (list channel) %default-channels))
+ (channel-introduction channel))))
+ `(channel (name ',(channel-name channel))
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,(channel-commit channel))
+ ,@(if intro
+ `((introduction
+ (make-channel-introduction
+ ,(channel-introduction-first-signed-commit intro)
+ (openpgp-fingerprint
+ ,(openpgp-format-fingerprint
+ (channel-introduction-first-commit-signer
+ intro))))))
+ '()))))
(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."
+ ;; TODO: Add CHANNEL's introduction. Currently we can't do that because
+ ;; older 'guix system describe' expect exactly name/url/branch/commit
+ ;; without any additional fields.
`(channel (name ,(channel-name channel))
(url ,(channel-url channel))
(branch ,(channel-branch channel))
(commit ,(channel-commit channel))))
+(define (sexp->channel sexp)
+ "Return the channel corresponding to SEXP, an sexp as found in the
+\"provenance\" file produced by 'provenance-service-type'."
+ (match sexp
+ (('channel ('name name)
+ ('url url)
+ ('branch branch)
+ ('commit commit)
+ rest ...)
+ ;; XXX: In the future REST may include a channel introduction.
+ (channel (name name) (url url)
+ (branch branch) (commit commit)))))
+
(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
(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
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
+information is missing, return the empty list (for channels) and possibly
+#false (for the configuration file)."
+ (catch 'system-error
+ (lambda ()
+ (sexp->system-provenance
+ (call-with-input-file (string-append system "/provenance")
+ read)))
+ (lambda _
+ (values '() #f))))
\f
;;;
;;; Cleanup.
"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
activation-service-type
%linux-kernel-activation))
+(define %hurd-rc-script
+ ;; The RC script to be started upon boot.
+ (program-file "rc"
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (gnu build hurd-boot)
+ (guix build syscalls)))
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build hurd-boot)
+ (guix build syscalls)
+ (ice-9 match)
+ (system repl repl)
+ (srfi srfi-1)
+ (srfi srfi-26))
+ (boot-hurd-system)))))
+
+(define (hurd-rc-entry rc)
+ "Return, as a monadic value, an entry for the RC script in the system
+directory."
+ (mlet %store-monad ((rc (lower-object rc)))
+ (return `(("rc" ,rc)))))
+
+(define hurd-startup-service-type
+ ;; The service that creates the initial SYSTEM/rc startup file.
+ (service-type (name 'startup)
+ (extensions
+ (list (service-extension system-service-type hurd-rc-entry)))
+ (default-value %hurd-rc-script)))
+
+(define %hurd-startup-service
+ ;; The service that produces the RC script.
+ (service hurd-startup-service-type %hurd-rc-script))
(define special-files-service-type
;; Service to install "special files" such as /bin/sh and /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
(define (packages->profile-entry packages)
"Return a system entry for the profile containing PACKAGES."
- (mlet %store-monad ((profile (profile-derivation
- (packages->manifest
- (delete-duplicates packages eq?)))))
- (return `(("profile" ,profile)))))
+ ;; 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?)))))))))
(define profile-service-type
;; The service that populates the system's profile---i.e.,
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
HCoop / jackhill / guix / guix.git / blobdiff