;;; 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 profiles)
#:use-module (guix sets)
#:use-module (guix ui)
+ #: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-kind
service-parameters
+ simple-service
modify-services
service-back-edges
fold-services
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
(type service-kind)
(parameters service-parameters))
+(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 (=>)
(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
+ (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.
one)
(_
(computed-file name
- #~(begin
- (use-modules (guix build union))
- (union-build #$output '#$things))
- #:modules '((guix build union))))))
+ (with-imported-modules '((guix build union))
+ #~(begin
+ (use-modules (guix build union))
+ (union-build #$output '#$things)))))))
(define* (activation-service->script service)
"Return as a monadic value the activation script for SERVICE, a service of
(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 build bournish)
- (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."
;; necessary or impossible in a container.
(service linux-bare-metal-service-type #f))
+(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)))
HCoop / jackhill / guix / guix.git / blobdiff