From df5ce088f2a0b7373eaa06ead9de580a86690180 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Sep 2014 17:12:33 +0200 Subject: system: Export '%setuid-programs'. * gnu/system.scm: Export '%setuid-programs', as documented in the manual. --- gnu/system.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index ea7fdf1cb78..067f4e16341 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -70,6 +70,7 @@ operating-system-profile operating-system-grub.cfg + %setuid-programs %base-packages)) ;;; Commentary: -- cgit v1.3 From c65e1834032d7f6e1bc4ebbc8157389a922f1e99 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Sep 2014 22:03:24 +0200 Subject: system: Add 'hosts-file' field. * gnu/system.scm ()[hosts-file]: New field. (default-/etc/hosts): New procedure. (etc-directory): Add #:hosts-file parameter and honor it. (operating-system-etc-directory): Build /etc/hosts, and pass it as #:hosts-file to 'etc-directory'. --- gnu/system.scm | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index 067f4e16341..20fe1d0a8f0 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -55,6 +55,7 @@ operating-system-user-services operating-system-packages operating-system-host-name + operating-system-hosts-file operating-system-kernel operating-system-initrd operating-system-users @@ -92,6 +93,8 @@ (default base-initrd)) (host-name operating-system-host-name) ; string + (hosts-file operating-system-hosts-file ; M item | #f + (default #f)) (file-systems operating-system-file-systems) ; list of fs @@ -221,12 +224,19 @@ explicitly appear in OS." " This is the GNU system. Welcome.\n") +(define (default-/etc/hosts host-name) + "Return the default /etc/hosts file." + (text-file "hosts" + (string-append "localhost 127.0.0.1\n" + host-name " 127.0.0.1\n"))) + (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") (issue "Hello!\n") (skeletons '()) (pam-services '()) (profile "/run/current-system/profile") + hosts-file (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad @@ -269,6 +279,7 @@ alias ll='ls -l' ("skel" ,#~#$skel) ("shells" ,#~#$shells) ("profile" ,#~#$bashrc) + ("hosts" ,#~#$hosts-file) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" #$timezone)) ("sudoers" ,#~#$sudoers))))) @@ -311,12 +322,15 @@ alias ll='ls -l' (append (operating-system-pam-services os) (append-map service-pam-services services)))) (profile-drv (operating-system-profile os)) - (skeletons (operating-system-skeletons os))) + (skeletons (operating-system-skeletons os)) + (/etc/hosts (or (operating-system-hosts-file os) + (default-/etc/hosts (operating-system-host-name os))))) (etc-directory #:pam-services pam-services #:skeletons skeletons #:issue (operating-system-issue os) #:locale (operating-system-locale os) #:timezone (operating-system-timezone os) + #:hosts-file /etc/hosts #:sudoers (operating-system-sudoers os) #:profile profile-drv))) -- cgit v1.3 From ee248b6a7043f308eaaa2b1deb708b52d4923659 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Sep 2014 22:18:52 +0200 Subject: activation: Make the /bin/sh symlink at activation time. * gnu/build/install.scm (directives): Remove "/bin/sh". * gnu/build/activation.scm (activate-/bin/sh): New procedure. * gnu/system.scm (operating-system-activation-script): Use it. --- gnu/build/activation.scm | 6 ++++++ gnu/build/install.scm | 1 - gnu/system.scm | 5 +++++ 3 files changed, 11 insertions(+), 1 deletion(-) (limited to 'gnu/system.scm') diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 009c1fff0a0..ee82a078b91 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -26,6 +26,7 @@ #:export (activate-users+groups activate-etc activate-setuid-programs + activate-/bin/sh activate-current-system)) ;;; Commentary: @@ -214,6 +215,11 @@ copy SOURCE to TARGET." (for-each make-setuid-program programs)) +(define (activate-/bin/sh shell) + "Change /bin/sh to point to SHELL." + (symlink shell "/bin/sh.new") + (rename-file "/bin/sh.new" "/bin/sh")) + (define %current-system ;; The system that is current (a symlink.) This is not necessarily the same ;; as the system we booted (aka. /run/booted-system) because we can re-build diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 7c4a7b7753b..a472259a4a0 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -113,7 +113,6 @@ STORE." ("/var/guix/gcroots/current-system" -> "/run/current-system") (directory "/bin") - ("/bin/sh" -> "/run/current-system/profile/bin/bash") (directory "/tmp" 0 0 #o1777) ; sticky bit (directory "/root" 0 0) ; an exception diff --git a/gnu/system.scm b/gnu/system.scm index 20fe1d0a8f0..abdd80bd6d6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -417,6 +417,11 @@ etc." (use-modules (gnu build activation)) + ;; Make sure /bin/sh is valid and current. + (activate-/bin/sh + (string-append #$(canonical-package bash) + "/bin/sh")) + ;; Populate /etc. (activate-etc #$etc) -- cgit v1.3 From c851400bee4f42d9ef582820a1badaa96ba72934 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Sep 2014 23:21:42 +0200 Subject: system: Add '\w' to the default PS1. * gnu/system.scm (etc-directory)[bashrc]: Add '\w' to PS1. --- gnu/system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/system.scm') diff --git a/gnu/system.scm b/gnu/system.scm index abdd80bd6d6..8a3f4f6ba88 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -252,7 +252,7 @@ This is the GNU system. Welcome.\n") ;; TODO: Generate bashrc from packages' search-paths. (bashrc (text-file* "bashrc" " -export PS1='\\u@\\h\\$ ' +export PS1='\\u@\\h \\w\\$ ' export LC_ALL=\"" locale "\" export TZ=\"" timezone "\" -- cgit v1.3 From 5dae0186dea1e72e73bf223161620cfeddef5a63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Sep 2014 23:39:15 +0200 Subject: system: Add support for Linux-style mapped devices. * gnu/system/file-systems.scm (): New record type. * gnu/system.scm ()[mapped-devices]: New field. (luks-device-mapping): New procedure. (other-file-system-services)[device-mappings, requirements]: New procedures. Pass #:requirements to 'file-system-service'. (device-mapping-services): New procedure. (essential-services): Use it. Append its result to the return value. (operating-system-initrd-file): Add comment. * gnu/services/base.scm (file-system-service): Add #:requirements parameter and honor it. (device-mapping-service): New procedure. * gnu/system/linux-initrd.scm (base-initrd): Add comment. --- gnu/services/base.scm | 24 ++++++++++++++-- gnu/system.scm | 67 +++++++++++++++++++++++++++++++++++++-------- gnu/system/file-systems.scm | 21 +++++++++++++- gnu/system/linux-initrd.scm | 1 + 4 files changed, 97 insertions(+), 16 deletions(-) (limited to 'gnu/system.scm') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index bf5af8369e0..014eef053ba 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -38,6 +38,7 @@ #:use-module (ice-9 format) #:export (root-file-system-service file-system-service + device-mapping-service user-processes-service host-name-service console-font-service @@ -99,18 +100,20 @@ This service must be the root of the service dependency graph so that its (define* (file-system-service device target type #:key (flags '()) (check? #t) - create-mount-point? options (title 'any)) + create-mount-point? options (title 'any) + (requirements '())) "Return a service that mounts DEVICE on TARGET as a file system TYPE with OPTIONS. TITLE is a symbol specifying what kind of name DEVICE is: 'label for a partition label, 'device for a device file name, or 'any. When CHECK? is true, check the file system before mounting it. When CREATE-MOUNT-POINT? is true, create TARGET if it does not exist yet. FLAGS is a list of symbols, -such as 'read-only' etc." +such as 'read-only' etc. Optionally, REQUIREMENTS may be a list of service +names such as device-mapping services." (with-monad %store-monad (return (service (provision (list (symbol-append 'file-system- (string->symbol target)))) - (requirement '(root-file-system)) + (requirement `(root-file-system ,@requirements)) (documentation "Check, mount, and unmount the given file system.") (start #~(lambda args (let ((device (canonicalize-device-spec #$device '#$title))) @@ -567,6 +570,21 @@ extra rules from the packages listed in @var{rules}." pid))))) (stop #~(make-kill-destructor)))))) +(define (device-mapping-service target command) + "Return a service that maps device @var{target}, a string such as +@code{\"home\"} (meaning @code{/dev/mapper/home}), by executing @var{command}, +a gexp." + (with-monad %store-monad + (return (service + (provision (list (symbol-append 'device-mapping- + (string->symbol target)))) + (requirement '(udev)) + (documentation "Map a device node using Linux's device mapper.") + (start #~(lambda () + #$command)) + (stop #~(const #f)) + (respawn? #f))))) + (define %base-services ;; Convenience variable holding the basic services. (let ((motd (text-file "motd" " diff --git a/gnu/system.scm b/gnu/system.scm index 8a3f4f6ba88..9bdf227eca3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -44,6 +44,7 @@ #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) #:use-module (gnu system file-systems) + #:autoload (gnu packages cryptsetup) (cryptsetup) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -64,6 +65,7 @@ operating-system-packages operating-system-timezone operating-system-locale + operating-system-mapped-devices operating-system-file-systems operating-system-activation-script @@ -72,7 +74,9 @@ operating-system-grub.cfg %setuid-programs - %base-packages)) + %base-packages + + luks-device-mapping)) ;;; Commentary: ;;; @@ -96,6 +100,8 @@ (hosts-file operating-system-hosts-file ; M item | #f (default #f)) + (mapped-devices operating-system-mapped-devices ; list of + (default '())) (file-systems operating-system-file-systems) ; list of fs (users operating-system-users ; list of user accounts @@ -152,6 +158,13 @@ file." ;;; Services. ;;; +(define (luks-device-mapping source target) + "Return a gexp that maps SOURCE to TARGET as a LUKS device, using +'cryptsetup'." + #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + "open" "--type" "luks" + #$source #$target))) + (define (other-file-system-services os) "Return file system services for the file systems of OS that are not marked as 'needed-for-boot'." @@ -161,30 +174,58 @@ as 'needed-for-boot'." (string=? "/" (file-system-mount-point fs)))) (operating-system-file-systems os))) + (define (device-mappings fs) + (filter (lambda (md) + (string=? (string-append "/dev/mapper/" + (mapped-device-target md)) + (file-system-device fs))) + (operating-system-mapped-devices os))) + + (define (requirements fs) + (map (lambda (md) + (symbol-append 'device-mapping- + (string->symbol (mapped-device-target md)))) + (device-mappings fs))) + (sequence %store-monad - (map (match-lambda - (($ device title target type flags opts - #f check? create?) - (file-system-service device target type - #:title title - #:check? check? - #:create-mount-point? create? - #:options opts - #:flags flags))) + (map (lambda (fs) + (match fs + (($ device title target type flags opts + #f check? create?) + (file-system-service device target type + #:title title + #:requirements (requirements fs) + #:check? check? + #:create-mount-point? create? + #:options opts + #:flags flags)))) file-systems))) +(define (device-mapping-services os) + "Return the list of device-mapping services for OS as a monadic list." + (sequence %store-monad + (map (lambda (md) + (let ((source (mapped-device-source md)) + (target (mapped-device-target md)) + (command (mapped-device-command md))) + (device-mapping-service target + (command source target)))) + (operating-system-mapped-devices os)))) + (define (essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." - (mlet* %store-monad ((root-fs (root-file-system-service)) + (mlet* %store-monad ((mappings (device-mapping-services os)) + (root-fs (root-file-system-service)) (other-fs (other-file-system-services os)) (procs (user-processes-service (map (compose first service-provision) other-fs))) (host-name (host-name-service (operating-system-host-name os)))) - (return (cons* host-name procs root-fs other-fs)))) + (return (cons* host-name procs root-fs + (append other-fs mappings))))) (define (operating-system-services os) "Return all the services of OS, including \"internal\" services that do not @@ -490,6 +531,8 @@ we're running in the final root." boot?)) (operating-system-file-systems os))) + ;; TODO: Pass the mapped devices required by boot-time file systems to the + ;; initrd. (mlet %store-monad ((initrd ((operating-system-initrd os) boot-file-systems))) (return #~(string-append #$initrd "/initrd")))) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 48c4fc7e773..90e2b0c796a 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -37,7 +37,13 @@ %pseudo-terminal-file-system %devtmpfs-file-system - %base-file-systems)) + %base-file-systems + + mapped-device + mapped-device? + mapped-device-source + mapped-device-target + mapped-device-command)) ;;; Commentary: ;;; @@ -128,4 +134,17 @@ %pseudo-terminal-file-system %shared-memory-file-system)) + + +;;; +;;; Mapped devices, for Linux's device-mapper. +;;; + +(define-record-type* mapped-device + make-mapped-device + mapped-device? + (source mapped-device-source) ;string + (target mapped-device-target) ;string + (command mapped-device-command)) ;source target -> gexp + ;;; file-systems.scm ends here diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index e83a9a5b23f..93f751b7571 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -131,6 +131,7 @@ initrd code." volatile-root? (extra-modules '()) guile-modules-in-chroot?) + ;; TODO: Support boot-time device mappings. "Return a monadic derivation that builds a generic initrd. FILE-SYSTEMS is a list of file-systems to be mounted by the initrd, possibly in addition to the root file system specified on the kernel command line via '--root'. -- cgit v1.3