diff options
Diffstat (limited to 'gnu/system.scm')
| -rw-r--r-- | gnu/system.scm | 91 |
1 files changed, 77 insertions, 14 deletions
diff --git a/gnu/system.scm b/gnu/system.scm index ea7fdf1cb7..9bdf227eca 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) @@ -55,6 +56,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 @@ -63,6 +65,7 @@ operating-system-packages operating-system-timezone operating-system-locale + operating-system-mapped-devices operating-system-file-systems operating-system-activation-script @@ -70,7 +73,10 @@ operating-system-profile operating-system-grub.cfg - %base-packages)) + %setuid-programs + %base-packages + + luks-device-mapping)) ;;; Commentary: ;;; @@ -91,7 +97,11 @@ (default base-initrd)) (host-name operating-system-host-name) ; string + (hosts-file operating-system-hosts-file ; M item | #f + (default #f)) + (mapped-devices operating-system-mapped-devices ; list of <mapped-device> + (default '())) (file-systems operating-system-file-systems) ; list of fs (users operating-system-users ; list of user accounts @@ -148,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'." @@ -157,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 - (($ <file-system> 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 + (($ <file-system> 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 @@ -220,12 +265,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 @@ -241,7 +293,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 "\" @@ -268,6 +320,7 @@ alias ll='ls -l' ("skel" ,#~#$skel) ("shells" ,#~#$shells) ("profile" ,#~#$bashrc) + ("hosts" ,#~#$hosts-file) ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" #$timezone)) ("sudoers" ,#~#$sudoers))))) @@ -310,12 +363,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))) @@ -402,6 +458,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) @@ -470,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")))) |