;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix store)
#:use-module (guix records)
#:use-module (guix profiles)
+ #:use-module (guix discovery)
#:use-module (guix sets)
#:use-module (guix ui)
+ #:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module (guix modules)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:export (service-extension
service-extension?
+ service-extension-target
+ service-extension-compute
service-type
service-type?
service-type-extensions
service-type-compose
service-type-extend
+ service-type-default-value
+ service-type-description
+ service-type-location
+
+ %service-type-path
+ fold-service-types
service
service?
service-kind
- service-parameters
+ service-value
+ service-parameters ;deprecated
+ simple-service
modify-services
service-back-edges
fold-services
service-error?
+ missing-value-service-error?
+ missing-value-service-error-type
+ missing-value-service-error-location
missing-target-service-error?
missing-target-service-error-service
missing-target-service-error-target-type
activation-service-type
activation-service->script
%linux-bare-metal-service
+ special-files-service-type
+ extra-special-file
etc-service-type
etc-directory
setuid-program-service-type
profile-service-type
firmware-service-type
+ gc-root-service-type
%boot-service
%activation-service
- etc-service
-
- file-union)) ;XXX: for lack of a better place
+ etc-service))
;;; Comment:
;;;
;;; 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
(target service-extension-target) ;<service-type>
(compute service-extension-compute)) ;params -> params
+(define &no-default-value
+ ;; Value used to denote service types that have no associated default value.
+ '(no default value))
+
(define-record-type* <service-type> service-type make-service-type
service-type?
(name service-type-name) ;symbol (for debugging)
;; Extend the services' own parameters with the extension composition.
(extend service-type-extend ;list of Any -> parameters
- (default #f)))
+ (default #f))
+
+ ;; Optional default value for instances of this type.
+ (default-value service-type-default-value ;Any
+ (default &no-default-value))
+
+ ;; Meta-data.
+ (description service-type-description ;string
+ (default #f))
+ (location service-type-location ;<location>
+ (default (and=> (current-source-location)
+ source-properties->location))
+ (innate)))
(define (write-service-type type port)
(format port "#<service-type ~a ~a>"
(set-record-type-printer! <service-type> write-service-type)
+(define %distro-root-directory
+ ;; Absolute file name of the module hierarchy.
+ (dirname (search-path %load-path "guix.scm")))
+
+(define %service-type-path
+ ;; Search path for service types.
+ (make-parameter `((,%distro-root-directory . "gnu/services")
+ (,%distro-root-directory . "gnu/system"))))
+
+(define* (fold-service-types proc seed
+ #:optional
+ (modules (all-modules (%service-type-path))))
+ "For each service type exported by one of MODULES, call (PROC RESULT). SEED
+is used as the initial value of RESULT."
+ (fold-module-public-variables (lambda (object result)
+ (if (service-type? object)
+ (proc object result)
+ result))
+ seed
+ modules))
+
;; Services of a given type.
(define-record-type <service>
- (service type parameters)
+ (make-service type value)
service?
(type service-kind)
- (parameters service-parameters))
+ (value service-value))
+
+(define-syntax service
+ (syntax-rules ()
+ "Return a service instance of TYPE. The service value is VALUE or, if
+omitted, TYPE's default value."
+ ((_ type value)
+ (make-service type value))
+ ((_ type)
+ (%service-with-default-value (current-source-location)
+ type))))
+
+(define (%service-with-default-value location type)
+ "Return a instance of service type TYPE with its default value, if any. If
+TYPE does not have a default value, an error is raised."
+ ;; TODO: Currently this is a run-time error but with a little bit macrology
+ ;; we could turn it into an expansion-time error.
+ (let ((default (service-type-default-value type)))
+ (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 \
+for service of type '~a'")
+ (location->string location)
+ (service-type-name type)))))))
+ (service type default))))
+
+(define-condition-type &service-error &error
+ service-error?)
+
+(define-condition-type &missing-value-service-error &service-error
+ missing-value-service-error?
+ (type missing-value-service-error-type)
+ (location missing-value-service-error-location))
+
+
+\f
+;;;
+;;; Helpers.
+;;;
+
+(define service-parameters
+ ;; Deprecated alias.
+ service-value)
+(define (simple-service name target value)
+ "Return a service that extends TARGET with VALUE. This works by creating a
+singleton service type NAME, of which the returned service is an instance."
+ (let* ((extension (service-extension target identity))
+ (type (service-type (name name)
+ (extensions (list extension)))))
+ (service type value)))
(define-syntax %modify-service
(syntax-rules (=>)
service)
((_ svc (kind param => exp ...) clauses ...)
(if (eq? (service-kind svc) kind)
- (let ((param (service-parameters svc)))
+ (let ((param (service-value svc)))
(service (service-kind svc)
(begin exp ...)))
(%modify-service svc clauses ...)))))
(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)
(define (compute-boot-script _ mexps)
(mlet %store-monad ((gexps (sequence %store-monad mexps)))
(gexp->file "boot"
- ;; Clean up and activate the system, then spawn dmd.
+ ;; Clean up and activate the system, then spawn shepherd.
#~(begin #$@gexps))))
(define (boot-script-entry mboot)
(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)))))))
+ (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'
+
+ (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.
(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
-use in the new directory, and the second element is a gexp denoting the target
-file."
- (computed-file name
- #~(begin
- (mkdir #$output)
- (chdir #$output)
- #$@(map (match-lambda
- ((target source)
- #~(symlink #$source #$target)))
- files))))
-
-(define (directory-union name things)
- "Return a directory that is the union of THINGS."
- (match things
- ((one)
- ;; Only one thing; return it.
- one)
- (_
- (computed-file name
- #~(begin
- (use-modules (guix build union))
- (union-build #$output '#$things))
- #:modules '((guix build union))))))
-
(define* (activation-service->script service)
"Return as a monadic value the activation script for SERVICE, a service of
ACTIVATION-SCRIPT-TYPE."
- (activation-script (service-parameters service)))
+ (activation-script (service-value service)))
(define (activation-script gexps)
"Return the system's activation script, which evaluates GEXPS."
- (define %modules
- '((gnu build activation)
- (gnu build linux-boot)
- (gnu build linux-modules)
- (gnu build file-systems)
- (guix build utils)
- (guix build syscalls)
- (guix elf)))
-
(define (service-activations)
;; Return the activation scripts for SERVICES.
(mapm %store-monad
(cut gexp->file "activate-service" <>)
gexps))
- (mlet* %store-monad ((actions (service-activations))
- (modules (imported-modules %modules))
- (compiled (compiled-modules %modules)))
+ (mlet* %store-monad ((actions (service-activations)))
(gexp->file "activate"
- #~(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)))
+ (with-imported-modules (source-module-closure
+ '((gnu build activation)
+ (guix build utils)))
+ #~(begin
+ (use-modules (gnu build activation)
+ (guix build utils))
- (use-modules (gnu build activation))
+ ;; Make sure the user accounting database exists. If it
+ ;; does not exist, 'setutxent' does not create it and
+ ;; thus there is no accounting at all.
+ (close-port (open-file "/var/run/utmpx" "a0"))
- ;; Make sure /bin/sh is valid and current.
- (activate-/bin/sh
- (string-append #$(canonical-package bash) "/bin/sh"))
+ ;; Same for 'wtmp', which is populated by mingetty et
+ ;; al.
+ (mkdir-p "/var/log")
+ (close-port (open-file "/var/log/wtmp" "a0"))
- ;; Run the services' activation snippets.
- ;; TODO: Use 'load-compiled'.
- (for-each primitive-load '#$actions)
+ ;; Set up /run/current-system. Among other things this
+ ;; sets up locales, which the activation snippets
+ ;; executed below may expect.
+ (activate-current-system)
- ;; Set up /run/current-system.
- (activate-current-system)))))
+ ;; Run the services' activation snippets.
+ ;; TODO: Use 'load-compiled'.
+ (for-each primitive-load '#$actions))))))
(define (gexps->activation-gexp gexps)
"Return a gexp that runs the activation script containing GEXPS."
;; Let users debug their own processes!
(activate-ptrace-attach)))
-(define linux-bare-metal-service-type
- (service-type (name 'linux-bare-metal)
- (extensions
- (list (service-extension activation-service-type
- (const %linux-kernel-activation))))))
-
(define %linux-bare-metal-service
;; The service that does things that are needed on the "bare metal", but not
;; necessary or impossible in a container.
- (service linux-bare-metal-service-type #f))
+ (simple-service 'linux-bare-metal
+ activation-service-type
+ %linux-kernel-activation))
+
+
+(define special-files-service-type
+ ;; Service to install "special files" such as /bin/sh and /usr/bin/env.
+ (service-type
+ (name 'special-files)
+ (extensions
+ (list (service-extension activation-service-type
+ (lambda (files)
+ #~(activate-special-files '#$files)))))
+ (compose concatenate)
+ (extend append)))
+
+(define (extra-special-file file target)
+ "Use TARGET as the \"special file\" FILE. For example, TARGET might be
+ (file-append coreutils \"/bin/env\")
+and FILE could be \"/usr/bin/env\"."
+ (simple-service (string->symbol (string-append "special-file-" file))
+ special-files-service-type
+ `((,file ,target))))
(define (etc-directory service)
"Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
- (files->etc-directory (service-parameters service)))
+ (files->etc-directory (service-value service)))
(define (files->etc-directory files)
(file-union "etc" files))
(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
(compose concatenate)
(extend append)))
+(define (gc-roots->system-entry roots)
+ "Return an entry in the system's output containing symlinks to ROOTS."
+ (mlet %store-monad ((entry (gexp->derivation
+ "gc-roots"
+ #~(let ((roots '#$roots))
+ (mkdir #$output)
+ (chdir #$output)
+ (for-each symlink
+ roots
+ (map number->string
+ (iota (length roots))))))))
+ (return (if (null? roots)
+ '()
+ `(("gc-roots" ,entry))))))
+
+(define gc-root-service-type
+ ;; A service to associate extra garbage-collector roots to the system. This
+ ;; is a simple hack that guarantees that the system retains references to
+ ;; the given list of roots. Roots must be "lowerable" objects like
+ ;; packages, or derivations.
+ (service-type (name 'gc-roots)
+ (extensions
+ (list (service-extension system-service-type
+ gc-roots->system-entry)))
+ (compose concatenate)
+ (extend append)))
+
\f
;;;
;;; Service folding.
;;;
-(define-condition-type &service-error &error
- service-error?)
-
(define-condition-type &missing-target-service-error &service-error
missing-target-service-error?
(service missing-target-service-error-service)
(target-type target-type))
(&message
(message
- (format #f (_ "no target of type '~a' for service ~s")
+ (format #f (G_ "no target of type '~a' for service '~a'")
(service-type-name target-type)
- service))))))
+ (service-type-name
+ (service-kind service))))))))
(x
(raise
(condition (&ambiguous-target-service-error
(&message
(message
(format #f
- (_ "more than one target service of type '~a'")
+ (G_ "more than one target service of type '~a'")
(service-type-name target-type))))))))))
(fold add-edge edges (service-type-extensions (service-kind service))))
(match (find (matching-extension target)
(service-type-extensions (service-kind service)))
(($ <service-extension> _ compute)
- (compute (service-parameters service))))))
+ (compute (service-value service))))))
(match (filter (lambda (service)
(eq? (service-kind service) target-type))
(extensions (map (apply-extension sink) dependents))
(extend (service-type-extend (service-kind sink)))
(compose (service-type-compose (service-kind sink)))
- (params (service-parameters 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 #f)
(target-type target-type))
(&message
- (message (format #f (_ "service of type '~a' not found")
+ (message (format #f (G_ "service of type '~a' not found")
(service-type-name target-type)))))))
(x
(raise
(&message
(message
(format #f
- (_ "more than one target service of type '~a'")
+ (G_ "more than one target service of type '~a'")
(service-type-name target-type)))))))))
;;; services.scm ends here.
HCoop / jackhill / guix / guix.git / blobdiff