diff options
Diffstat (limited to 'gnu/system.scm')
| -rw-r--r-- | gnu/system.scm | 553 |
1 files changed, 342 insertions, 211 deletions
diff --git a/gnu/system.scm b/gnu/system.scm index 96f721330f..06bec40cef 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -19,6 +19,7 @@ (define-module (gnu system) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix derivations) @@ -33,14 +34,17 @@ #:use-module (gnu system shadow) #:use-module (gnu system linux) #:use-module (gnu system linux-initrd) + #:use-module (gnu system file-systems) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (operating-system operating-system? + + operating-system-bootloader operating-system-services + operating-system-user-services operating-system-packages - operating-system-bootloader-entries operating-system-host-name operating-system-kernel operating-system-initrd @@ -49,10 +53,11 @@ operating-system-packages operating-system-timezone operating-system-locale - operating-system-services + operating-system-file-systems - operating-system-profile-directory - operating-system-derivation)) + operating-system-derivation + operating-system-profile + operating-system-grub.cfg)) ;;; Commentary: ;;; @@ -67,12 +72,10 @@ operating-system? (kernel operating-system-kernel ; package (default linux-libre)) - (bootloader operating-system-bootloader ; package - (default grub)) - (bootloader-entries operating-system-bootloader-entries ; list - (default '())) - (initrd operating-system-initrd ; monadic derivation - (default (gnu-system-initrd))) + (bootloader operating-system-bootloader) ; <grub-configuration> + + (initrd operating-system-initrd ; (list fs) -> M derivation + (default qemu-initrd)) (host-name operating-system-host-name) ; string @@ -84,11 +87,10 @@ (groups operating-system-groups ; list of user groups (default (list (user-group (name "root") - (id 0)) - (user-group - (name "users") - (id 100) - (members '("guest")))))) + (id 0))))) + + (skeletons operating-system-skeletons ; list of name/monadic value + (default (default-skeletons))) (packages operating-system-packages ; list of (PACKAGE OUTPUT...) (default (list coreutils ; or just PACKAGE @@ -104,9 +106,16 @@ (timezone operating-system-timezone) ; string (locale operating-system-locale) ; string - (services operating-system-services ; list of monadic services - (default %base-services))) + (services operating-system-user-services ; list of monadic services + (default %base-services)) + + (pam-services operating-system-pam-services ; list of PAM services + (default (base-pam-services))) + (setuid-programs operating-system-setuid-programs + (default %setuid-programs)) ; list of string-valued gexps + (sudoers operating-system-sudoers ; /etc/sudoers contents + (default %sudoers-specification))) ;;; @@ -119,122 +128,104 @@ "Return a derivation that builds the union of INPUTS. INPUTS is a list of input tuples." (define builder - '(begin - (use-modules (guix build union)) + #~(begin + (use-modules (guix build union)) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (define inputs '#$inputs) - (let ((output (assoc-ref %outputs "out")) - (inputs (map cdr %build-inputs))) - (format #t "building union `~a' with ~a packages...~%" - output (length inputs)) - (union-build output inputs)))) + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) - (mlet %store-monad - ((inputs (sequence %store-monad - (map (match-lambda - ((or ((? package? p)) (? package? p)) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv)))) - (((? package? p) output) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv ,output)))) - (x - (return x))) - inputs)))) - (derivation-expression name builder - #:system system - #:inputs inputs - #:modules '((guix build union)) - #:guile-for-build guile - #:local-build? #t))) - -(define* (file-union files - #:key (inputs '()) (name "file-union")) + (format #t "building union `~a' with ~a packages...~%" + #$output (length inputs)) + (union-build #$output inputs))) + + (gexp->derivation name builder + #:system system + #:modules '((guix build union)) + #:guile-for-build guile + #:local-build? #t)) + +(define* (file-union name files) "Return a derivation 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 the target file. - -The subset of FILES corresponding to plain store files is automatically added -as an inputs; additional inputs, such as derivations, are taken from INPUTS." - (mlet %store-monad ((inputs (lower-inputs inputs))) - (let* ((outputs (append-map (match-lambda - ((_ (? derivation? drv)) - (list (derivation->output-path drv))) - ((_ (? derivation? drv) sub-drv ...) - (map (cut derivation->output-path drv <>) - sub-drv)) - (_ '())) - inputs)) - (inputs (append inputs - (filter (match-lambda - ((_ file) - ;; Elements of FILES that are store - ;; files and that do not correspond to - ;; the output of INPUTS are considered - ;; inputs (still here?). - (and (direct-store-path? file) - (not (member file outputs))))) - files)))) - (derivation-expression name - `(let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - ,@(map (match-lambda - ((name target) - `(symlink ,target ,name))) - files)) - - #:inputs inputs - #:local-build? #t)))) - -(define (links inputs) - "Return a directory with symbolic links to all of INPUTS. This is -essentially useful when one wants to keep references to all of INPUTS, be they -directories or regular files." +in the new directory, and the second element is a gexp denoting the target +file." (define builder - '(begin - (use-modules (srfi srfi-1)) - - (let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (chdir out) - (fold (lambda (file number) - (symlink file (number->string number)) - (+ 1 number)) - 0 - (map cdr %build-inputs)) - #t))) - - (mlet %store-monad ((inputs (lower-inputs inputs))) - (derivation-expression "links" builder - #:inputs inputs - #:local-build? #t))) + #~(begin + (mkdir #$output) + (chdir #$output) + #$@(map (match-lambda + ((target source) + #~(symlink #$source #$target))) + files))) + + (gexp->derivation name builder)) + + +;;; +;;; Services. +;;; + +(define (other-file-system-services os) + "Return file system services for the file systems of OS that are not marked +as 'needed-for-boot'." + (define file-systems + (remove (lambda (fs) + (or (file-system-needed-for-boot? fs) + (string=? "/" (file-system-mount-point fs)))) + (operating-system-file-systems os))) + + (sequence %store-monad + (map (match-lambda + (($ <file-system> device target type flags opts #f check?) + (file-system-service device target type + #:check? check? + #:options opts))) + file-systems))) + +(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)) + (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)))) + +(define (operating-system-services os) + "Return all the services of OS, including \"internal\" services that do not +explicitly appear in OS." + (mlet %store-monad + ((user (sequence %store-monad (operating-system-user-services os))) + (essential (essential-services os))) + (return (append essential user)))) + + +;;; +;;; /etc. +;;; (define* (etc-directory #:key (locale "C") (timezone "Europe/Paris") - (accounts '()) - (groups '()) + (skeletons '()) (pam-services '()) - (profile "/var/run/current-system/profile")) + (profile "/run/current-system/profile") + (sudoers "")) "Return a derivation that builds the static part of the /etc directory." (mlet* %store-monad - ((services (package-file net-base "etc/services")) - (protocols (package-file net-base "etc/protocols")) - (rpc (package-file net-base "etc/rpc")) - (passwd (passwd-file accounts)) - (shadow (passwd-file accounts #:shadow? #t)) - (group (group-file groups)) - (pam.d (pam-services->directory pam-services)) + ((pam.d (pam-services->directory pam-services)) + (sudoers (text-file "sudoers" sudoers)) (login.defs (text-file "login.defs" "# Empty for now.\n")) (shells (text-file "shells" ; used by xterm and others "\ /bin/sh -/run/current-system/bin/sh -/run/current-system/bin/bash\n")) +/run/current-system/profile/bin/sh +/run/current-system/profile/bin/bash\n")) (issue (text-file "issue" " This is an alpha preview of the GNU system. Welcome. @@ -253,119 +244,259 @@ export LC_ALL=\"" locale "\" export TZ=\"" timezone "\" export TZDIR=\"" tzdata "/share/zoneinfo\" -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin +export PATH=/run/setuid-programs:/run/current-system/profile/sbin +export PATH=$HOME/.guix-profile/bin:/run/current-system/profile/bin:$PATH export CPATH=$HOME/.guix-profile/include:" profile "/include export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib alias ls='ls -p --color' alias ll='ls -l' ")) - - (tz-file (package-file tzdata - (string-append "share/zoneinfo/" timezone))) - (files -> `(("services" ,services) - ("protocols" ,protocols) - ("rpc" ,rpc) - ("pam.d" ,(derivation->output-path pam.d)) - ("login.defs" ,login.defs) - ("issue" ,issue) - ("shells" ,shells) - ("profile" ,(derivation->output-path bashrc)) - ("localtime" ,tz-file) - ("passwd" ,passwd) - ("shadow" ,shadow) - ("group" ,group)))) - (file-union files - #:inputs `(("net" ,net-base) - ("pam.d" ,pam.d) - ("bashrc" ,bashrc) - ("tzdata" ,tzdata)) - #:name "etc"))) - -(define (operating-system-profile-derivation os) + (skel (skeleton-directory skeletons))) + (file-union "etc" + `(("services" ,#~(string-append #$net-base "/etc/services")) + ("protocols" ,#~(string-append #$net-base "/etc/protocols")) + ("rpc" ,#~(string-append #$net-base "/etc/rpc")) + ("pam.d" ,#~#$pam.d) + ("login.defs" ,#~#$login.defs) + ("issue" ,#~#$issue) + ("skel" ,#~#$skel) + ("shells" ,#~#$shells) + ("profile" ,#~#$bashrc) + ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/" + #$timezone)) + ("sudoers" ,#~#$sudoers))))) + +(define (operating-system-profile os) "Return a derivation that builds the default profile of OS." ;; TODO: Replace with a real profile with a manifest. (union (operating-system-packages os) #:name "default-profile")) -(define (operating-system-profile-directory os) - "Return the directory name of the default profile of OS." - (mlet %store-monad ((drv (operating-system-profile-derivation os))) - (return (derivation->output-path drv)))) - -(define (operating-system-derivation os) - "Return a derivation that builds OS." +(define %root-account + ;; Default root account. + (user-account + (name "root") + (password "") + (uid 0) (group "root") + (comment "System administrator") + (home-directory "/root"))) + +(define (operating-system-accounts os) + "Return the user accounts for OS, including an obligatory 'root' account." + (define users + ;; Make sure there's a root account. + (if (find (lambda (user) + (and=> (user-account-uid user) zero?)) + (operating-system-users os)) + (operating-system-users os) + (cons %root-account (operating-system-users os)))) + + (mlet %store-monad ((services (operating-system-services os))) + (return (append users + (append-map service-user-accounts services))))) + +(define (operating-system-etc-directory os) + "Return that static part of the /etc directory of OS." (mlet* %store-monad - ((services (sequence %store-monad - (cons (host-name-service - (operating-system-host-name os)) - (operating-system-services os)))) + ((services (operating-system-services os)) (pam-services -> ;; Services known to PAM. (delete-duplicates - (cons %pam-other-services - (append-map service-pam-services services)))) - - (bash-file (package-file bash "bin/bash")) - (dmd-file (package-file (@ (gnu packages admin) dmd) "bin/dmd")) - (accounts -> (cons (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/root")) - (append (operating-system-users os) - (append-map service-user-accounts - services)))) - (groups -> (append (operating-system-groups os) - (append-map service-user-groups services))) - - (profile-drv (operating-system-profile-derivation os)) - (profile -> (derivation->output-path profile-drv)) - (etc-drv (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services - #:locale (operating-system-locale os) - #:timezone (operating-system-timezone os) - #:profile profile-drv)) - (etc -> (derivation->output-path etc-drv)) - (dmd-conf (dmd-configuration-file services etc)) - - - (boot (text-file "boot" - (object->string - `(execl ,dmd-file "dmd" - "--config" ,dmd-conf)))) - (kernel -> (operating-system-kernel os)) - (kernel-dir (package-file kernel)) - (initrd (operating-system-initrd os)) - (initrd-file -> (string-append (derivation->output-path initrd) - "/initrd")) + (append (operating-system-pam-services os) + (append-map service-pam-services services)))) + (profile-drv (operating-system-profile os)) + (skeletons (operating-system-skeletons os))) + (etc-directory #:pam-services pam-services + #:skeletons skeletons + #:locale (operating-system-locale os) + #:timezone (operating-system-timezone os) + #:sudoers (operating-system-sudoers os) + #:profile profile-drv))) + +(define %setuid-programs + ;; Default set of setuid-root programs. + (let ((shadow (@ (gnu packages admin) shadow))) + (list #~(string-append #$shadow "/bin/passwd") + #~(string-append #$shadow "/bin/su") + #~(string-append #$inetutils "/bin/ping") + #~(string-append #$sudo "/bin/sudo")))) + +(define %sudoers-specification + ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel' + ;; group can do anything. See + ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>. + ;; TODO: Add a declarative API. + "root ALL=(ALL) ALL +%wheel ALL=(ALL) ALL\n") + +(define (user-group->gexp group) + "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for +'active-groups'." + #~(list #$(user-group-name group) + #$(user-group-password group) + #$(user-group-id group))) + +(define (user-account->gexp account) + "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for +'activate-users'." + #~`(#$(user-account-name account) + #$(user-account-uid account) + #$(user-account-group account) + #$(user-account-supplementary-groups account) + #$(user-account-comment account) + #$(user-account-home-directory account) + ,#$(user-account-shell account) ; this one is a gexp + #$(user-account-password account))) + +(define (operating-system-activation-script os) + "Return the activation script for OS---i.e., the code that \"activates\" the +stateful part of OS, including user accounts and groups, special directories, +etc." + (define %modules + '((guix build activation) + (guix build utils) + (guix build linux-initrd))) + + (define (service-activations services) + ;; Return the activation scripts for SERVICES. + (let ((gexps (filter-map service-activate services))) + (sequence %store-monad (map (cut gexp->file "activate-service.scm" <>) + gexps)))) + + (mlet* %store-monad ((services (operating-system-services os)) + (actions (service-activations services)) + (etc (operating-system-etc-directory os)) + (modules (imported-modules %modules)) + (compiled (compiled-modules %modules)) + (accounts (operating-system-accounts os))) + (define setuid-progs + (operating-system-setuid-programs os)) + + (define user-specs + (map user-account->gexp accounts)) + + (define groups + (append (operating-system-groups os) + (append-map service-user-groups services))) + + (define group-specs + (map user-group->gexp groups)) + + (gexp->file "boot" + #~(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 activation)) + + ;; Populate /etc. + (activate-etc #$etc) + + ;; Add users and user groups. + (setenv "PATH" + (string-append #$(@ (gnu packages admin) shadow) + "/sbin")) + (activate-users+groups (list #$@user-specs) + (list #$@group-specs)) + + ;; Activate setuid programs. + (activate-setuid-programs (list #$@setuid-progs)) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions) + + ;; Set up /run/current-system. + (activate-current-system))))) + +(define (operating-system-boot-script os) + "Return the boot script for OS---i.e., the code started by the initrd once +we're running in the final root." + (mlet* %store-monad ((services (operating-system-services os)) + (activate (operating-system-activation-script os)) + (dmd-conf (dmd-configuration-file services))) + (gexp->file "boot" + #~(begin + ;; Activate the system. + ;; TODO: Use 'load-compiled'. + (primitive-load #$activate) + + ;; Keep track of the booted system. + (false-if-exception (delete-file "/run/booted-system")) + (symlink (readlink "/run/current-system") + "/run/booted-system") + + ;; Close any remaining open file descriptors to be on the + ;; safe side. This must be the very last thing we do, + ;; because Guile has internal FDs such as 'sleep_pipe' + ;; that need to be alive. + (let loop ((fd 3)) + (when (< fd 1024) + (false-if-exception (close-fdes fd)) + (loop (+ 1 fd)))) + + ;; Start dmd. + (execl (string-append #$dmd "/bin/dmd") + "dmd" "--config" #$dmd-conf))))) + +(define (operating-system-root-file-system os) + "Return the root file system of OS." + (find (match-lambda + (($ <file-system> _ "/") #t) + (_ #f)) + (operating-system-file-systems os))) + +(define (operating-system-initrd-file os) + "Return a gexp denoting the initrd file of OS." + (define boot-file-systems + (filter (match-lambda + (($ <file-system> device "/") + #t) + (($ <file-system> device mount-point type flags options boot?) + boot?)) + (operating-system-file-systems os))) + + (mlet %store-monad + ((initrd ((operating-system-initrd os) boot-file-systems))) + (return #~(string-append #$initrd "/initrd")))) + +(define (operating-system-grub.cfg os) + "Return the GRUB configuration file for OS." + (mlet* %store-monad + ((system (operating-system-derivation os)) + (root-fs -> (operating-system-root-file-system os)) + (kernel -> (operating-system-kernel os)) (entries -> (list (menu-entry (label (string-append "GNU system with " (package-full-name kernel) " (technology preview)")) (linux kernel) - (linux-arguments `("--root=/dev/sda1" - ,(string-append "--load=" boot))) - (initrd initrd-file)))) - (grub.cfg (grub-configuration-file entries)) - (extras (links (delete-duplicates - (append (append-map service-inputs services) - (append-map user-account-inputs accounts)))))) - (file-union `(("boot" ,boot) - ("kernel" ,kernel-dir) - ("initrd" ,initrd-file) - ("dmd.conf" ,dmd-conf) - ("profile" ,profile) - ("grub.cfg" ,grub.cfg) - ("etc" ,etc) - ("system-inputs" ,(derivation->output-path extras))) - #:inputs `(("kernel" ,kernel) - ("initrd" ,initrd) - ("bash" ,bash) - ("profile" ,profile-drv) - ("etc" ,etc-drv) - ("system-inputs" ,extras)) - #:name "system"))) + (linux-arguments + (list (string-append "--root=" + (file-system-device root-fs)) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system + "/boot"))) + (initrd #~(string-append #$system "/initrd")))))) + (grub-configuration-file (operating-system-bootloader os) entries))) + +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((profile (operating-system-profile os)) + (etc (operating-system-etc-directory os)) + (boot (operating-system-boot-script os)) + (kernel -> (operating-system-kernel os)) + (initrd (operating-system-initrd-file os))) + (file-union "system" + `(("boot" ,#~#$boot) + ("kernel" ,#~#$kernel) + ("initrd" ,initrd) + ("profile" ,#~#$profile) + ("etc" ,#~#$etc))))) ;;; system.scm ends here |