diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/system.scm | 341 | ||||
| -rw-r--r-- | gnu/system/grub.scm | 14 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 301 |
3 files changed, 395 insertions, 261 deletions
diff --git a/gnu/system.scm b/gnu/system.scm new file mode 100644 index 0000000000..79d87855f6 --- /dev/null +++ b/gnu/system.scm @@ -0,0 +1,341 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu system) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (gnu packages linux-initrd) + #:use-module (gnu packages base) + #:use-module (gnu packages bash) + #:use-module (gnu packages system) + #:use-module (gnu packages package-management) + #:use-module (gnu system dmd) + #:use-module (gnu system grub) + #:use-module (gnu system shadow) + #:use-module (gnu system linux) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (operating-system + operating-system? + operating-system-services + operating-system-packages + + operating-system-derivation)) + +;;; Commentary: +;;; +;;; This module supports whole-system configuration. +;;; +;;; Code: + +;; System-wide configuration. +;; TODO: Add per-field docstrings/stexi. +(define-record-type* <operating-system> operating-system + make-operating-system + 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 + (default gnu-system-initrd)) + + (host-name operating-system-host-name) ; string + + (file-systems operating-system-file-systems ; list of fs + (default '())) + + (users operating-system-users ; list of user accounts + (default '())) + (groups operating-system-groups ; list of user groups + (default (list (user-group + (name "root") + (id 0)) + (user-group + (name "users") + (id 100) + (members '("guest")))))) + + (packages operating-system-packages ; list of (PACKAGE OUTPUT...) + (default `(("coreutils" ,coreutils) + ("grep" ,grep) + ("guile" ,guile) + ("bash" ,bash) + ("dmd" ,(@ (gnu packages dmd) dmd)) + ("guix" ,guix)))) + + (timezone operating-system-timezone) ; string + (locale operating-system-locale) ; string + + (services operating-system-services ; list of monadic services + (default + (let ((motd (text-file "motd" " +This is the GNU operating system, welcome!\n\n"))) + (list (mingetty-service "tty1" #:motd motd) + (mingetty-service "tty2" #:motd motd) + (mingetty-service "tty3" #:motd motd) + (mingetty-service "tty4" #:motd motd) + (mingetty-service "tty5" #:motd motd) + (mingetty-service "tty6" #:motd motd) + (syslog-service) + (guix-service) + (nscd-service) + + ;; QEMU networking settings. + (static-networking-service "eth0" "10.0.2.10" + #:name-servers '("10.0.2.3") + #:gateway "10.0.2.2")))))) + + + +;;; +;;; Derivation. +;;; + +(define* (union inputs + #:key (guile (%guile-for-build)) (system (%current-system)) + (name "union")) + "Return a derivation that builds the union of INPUTS. INPUTS is a list of +input tuples." + (define builder + '(begin + (use-modules (guix build union)) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (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)))) + + (mlet %store-monad + ((inputs (sequence %store-monad + (map (match-lambda + ((name (? package? p)) + (mlet %store-monad + ((drv (package->derivation p system))) + (return `(,name ,drv)))) + ((name (? 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))) + +(define* (file-union files + #:key (inputs '()) (name "file-union")) + "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)))) + +(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." + (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))) + +(define* (etc-directory #:key + (accounts '()) + (groups '()) + (pam-services '()) + (profile "/var/run/current-system/profile")) + "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)) + (login.defs (text-file "login.defs" "# Empty for now.\n")) + (issue (text-file "issue" " +This is an alpha preview of the GNU system. Welcome. + +This image features the GNU Guix package manager, which was used to +build it (http://www.gnu.org/software/guix/). The init system is +GNU dmd (http://www.gnu.org/software/dmd/). + +You can log in as 'guest' or 'root' with no password. +")) + + ;; TODO: Generate bashrc from packages' search-paths. + (bashrc (text-file "bashrc" (string-append " +export PS1='\\u@\\h\\$ ' +export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin +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' +"))) + + (files -> `(("services" ,services) + ("protocols" ,protocols) + ("rpc" ,rpc) + ("pam.d" ,(derivation->output-path pam.d)) + ("login.defs" ,login.defs) + ("issue" ,issue) + ("profile" ,bashrc) + ("passwd" ,passwd) + ("shadow" ,shadow) + ("group" ,group)))) + (file-union files + #:inputs `(("net" ,net-base) + ("pam.d" ,pam.d)) + #:name "etc"))) + +(define (operating-system-derivation os) + "Return a derivation that builds OS." + (mlet* %store-monad + ((services (sequence %store-monad + (cons (host-name-service + (operating-system-host-name os)) + (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 system) dmd) "bin/dmd")) + (accounts -> (cons (user-account + (name "root") + (password "") + (uid 0) (gid 0) + (comment "System administrator") + (home-directory "/") + (shell bash-file)) + (append (operating-system-users os) + (append-map service-user-accounts + services)))) + (groups -> (append (operating-system-groups os) + (append-map service-user-groups services))) + (packages -> (operating-system-packages os)) + + ;; TODO: Replace with a real profile with a manifest. + (profile-drv (union packages + #:name "default-profile")) + (profile -> (derivation->output-path profile-drv)) + (etc-drv (etc-directory #:accounts accounts #:groups groups + #:pam-services pam-services + #:profile profile)) + (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 (package-file initrd)) + (entries -> (list (menu-entry + (label (string-append + "GNU system with " + (package-full-name kernel) + " (technology preview)")) + (linux kernel) + (linux-arguments `("--root=/dev/vda1" + ,(string-append "--load=" boot))) + (initrd initrd)))) + (grub.cfg (grub-configuration-file entries)) + (extras (links (delete-duplicates + (append-map service-inputs services))))) + (file-union `(("boot" ,boot) + ("kernel" ,kernel-dir) + ("initrd" ,initrd-file) + ("dmd.conf" ,dmd-conf) + ("bash" ,bash-file) ; XXX: should be a <user-account> input? + ("profile" ,profile) + ("grub.cfg" ,grub.cfg) + ("etc" ,etc) + ("service-inputs" ,(derivation->output-path extras))) + #:inputs `(("kernel" ,kernel) + ("initrd" ,initrd) + ("bash" ,bash) + ("profile" ,profile-drv) + ("etc" ,etc-drv) + ("service-inputs" ,extras)) + #:name "system"))) + +;;; system.scm ends here diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index abc220b532..86fa9b504d 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -56,12 +56,11 @@ search.file ~a~%" default-entry timeout kernel)) (define (bzImage) - (anym %store-monad - (match-lambda - (($ <menu-entry> _ linux) - (package-file linux "bzImage" - #:system system))) - entries)) + (any (match-lambda + (($ <menu-entry> _ linux) + (package-file linux "bzImage" + #:system system))) + entries)) (define entry->text (match-lambda @@ -79,7 +78,8 @@ search.file ~a~%" linux (string-join arguments) initrd)))))) (mlet %store-monad ((kernel (bzImage)) - (body (mapm %store-monad entry->text entries))) + (body (sequence %store-monad + (map entry->text entries)))) (text-file "grub.cfg" (string-append (prologue kernel) (string-concatenate body))))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 7afbd70044..3717e2ac23 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -43,6 +43,7 @@ #:use-module (gnu system linux) #:use-module (gnu system grub) #:use-module (gnu system dmd) + #:use-module (gnu system) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -59,21 +60,6 @@ ;;; ;;; Code: -(define (lower-inputs inputs) - "Turn any package from INPUTS into a derivation; return the corresponding -input list as a monadic value." - (with-monad %store-monad - (sequence %store-monad - (map (match-lambda - ((name (? package? package) sub-drv ...) - (mlet %store-monad ((drv (package->derivation package))) - (return `(,name ,drv ,@sub-drv)))) - ((name (? string? file)) - (return `(,name ,file))) - (tuple - (return tuple))) - inputs)))) - (define* (expression->derivation-in-linux-vm name exp #:key (system (%current-system)) @@ -217,7 +203,7 @@ made available under the /xchg CIFS share." (inputs-to-copy '())) "Return a bootable, stand-alone QEMU image. The returned image is a full disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its -configuration file. +configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied into the image being built. When INITIALIZE-STORE? is true, initialize the @@ -262,7 +248,7 @@ such as /etc files." "/sbin/grub-install")) (umount (string-append (assoc-ref %build-inputs "util-linux") "/bin/umount")) ; XXX: add to Guile - (grub.cfg (assoc-ref %build-inputs "grub.cfg"))) + (grub.cfg ,grub-configuration)) (define (read-reference-graph port) ;; Return a list of store paths from the reference graph at PORT. @@ -324,7 +310,7 @@ such as /etc files." (copy-recursively thing (string-append "/fs" thing))) - (cons grub.cfg (things-to-copy))) + (things-to-copy)) ;; Populate /dev. (make-essential-device-nodes #:root "/fs") @@ -394,7 +380,6 @@ such as /etc files." #:inputs `(("parted" ,parted) ("grub" ,grub) ("e2fsprogs" ,e2fsprogs) - ("grub.cfg" ,grub-configuration) ;; For shell scripts. ("sed" ,(car (assoc-ref %final-inputs "sed"))) @@ -420,255 +405,63 @@ such as /etc files." ;;; Stand-alone VM image. ;;; -(define* (union inputs - #:key (guile (%guile-for-build)) (system (%current-system)) - (name "union")) - "Return a derivation that builds the union of INPUTS. INPUTS is a list of -input tuples." - (define builder - '(begin - (use-modules (guix build union)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (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)))) - - (mlet %store-monad - ((inputs (sequence %store-monad - (map (match-lambda - ((name (? package? p)) - (mlet %store-monad - ((drv (package->derivation p system))) - (return `(,name ,drv)))) - ((name (? 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))) - -(define* (file-union files - #:key (inputs '()) (name "file-union")) - "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)))) - -(define* (etc-directory #:key - (accounts '()) - (groups '()) - (pam-services '()) - (profile "/var/run/current-system/profile")) - "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)) - (login.defs (text-file "login.defs" "# Empty for now.\n")) - (issue (text-file "issue" " -This is an alpha preview of the GNU system. Welcome. - -This image features the GNU Guix package manager, which was used to -build it (http://www.gnu.org/software/guix/). The init system is -GNU dmd (http://www.gnu.org/software/dmd/). - -You can log in as 'guest' or 'root' with no password. -")) - - ;; TODO: Generate bashrc from packages' search-paths. - (bashrc (text-file "bashrc" (string-append " -export PS1='\\u@\\h\\$ ' -export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin -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' -"))) - - (files -> `(("services" ,services) - ("protocols" ,protocols) - ("rpc" ,rpc) - ("pam.d" ,(derivation->output-path pam.d)) - ("login.defs" ,login.defs) - ("issue" ,issue) - ("profile" ,bashrc) - ("passwd" ,passwd) - ("shadow" ,shadow) - ("group" ,group)))) - (file-union files - #:inputs `(("net" ,net-base) - ("pam.d" ,pam.d)) - #:name "etc"))) - -(define (system-qemu-image) +(define %demo-operating-system + (operating-system + (host-name "gnu") + (timezone "Europe/Paris") + (locale "C.UTF-8") + (users (list (user-account + (name "guest") + (password "") + (uid 1000) (gid 100) + (comment "Guest of GNU") + (home-directory "/home/guest") + ;; (shell bash-file) + ))) + (packages `(("coreutils" ,coreutils) + ("bash" ,bash) + ("guile" ,guile-2.0) + ("dmd" ,dmd) + ("gcc" ,gcc-final) + ("libc" ,glibc-final) + ("inetutils" ,inetutils) + ("findutils" ,findutils) + ("grep" ,grep) + ("sed" ,sed) + ("procps" ,procps) + ("psmisc" ,psmisc) + ("zile" ,zile) + ("guix" ,guix))))) + +(define* (system-qemu-image #:optional (os %demo-operating-system)) "Return the derivation of a QEMU image of the GNU system." (mlet* %store-monad - ((services (listm %store-monad - (host-name-service "gnu") - (mingetty-service "tty1") - (mingetty-service "tty2") - (mingetty-service "tty3") - (mingetty-service "tty4") - (mingetty-service "tty5") - (mingetty-service "tty6") - (syslog-service) - (guix-service) - (nscd-service) - - ;; QEMU networking settings. - (static-networking-service "eth0" "10.0.2.10" - #:name-servers '("10.0.2.3") - #:gateway "10.0.2.2"))) - (motd (text-file "motd" " -Happy birthday, GNU! http://www.gnu.org/gnu30 - -")) - (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 dmd "bin/dmd")) - (accounts -> (cons* (user-account - (name "root") - (password "") - (uid 0) (gid 0) - (comment "System administrator") - (home-directory "/") - (shell bash-file)) - (user-account - (name "guest") - (password "") - (uid 1000) (gid 100) - (comment "Guest of GNU") - (home-directory "/home/guest") - (shell bash-file)) - (append-map service-user-accounts - services))) - (groups -> (cons* (user-group - (name "root") - (id 0)) - (user-group - (name "users") - (id 100) - (members '("guest"))) - (append-map service-user-groups services))) - (build-user-gid -> (any (lambda (service) - (and (equal? '(guix-daemon) - (service-provision service)) - (match (service-user-groups service) - ((group) - (user-group-id group))))) - services)) - (packages -> `(("coreutils" ,coreutils) - ("bash" ,bash) - ("guile" ,guile-2.0) - ("dmd" ,dmd) - ("gcc" ,gcc-final) - ("libc" ,glibc-final) - ("inetutils" ,inetutils) - ("findutils" ,findutils) - ("grep" ,grep) - ("sed" ,sed) - ("procps" ,procps) - ("psmisc" ,psmisc) - ("zile" ,zile) - ("guix" ,guix))) - - ;; TODO: Replace with a real profile with a manifest. - (profile-drv (union packages - #:name "default-profile")) - (profile -> (derivation->output-path profile-drv)) - (etc-drv (etc-directory #:accounts accounts #:groups groups - #:pam-services pam-services - #:profile profile)) - (etc -> (derivation->output-path etc-drv)) - (dmd-conf (dmd-configuration-file services etc)) - - + ((os-drv (operating-system-derivation os)) + (os-dir -> (derivation->output-path os-drv)) + (grub.cfg -> (string-append os-dir "/grub.cfg")) + (build-user-gid (anym %store-monad ; XXX + (lambda (service) + (and (equal? '(guix-daemon) + (service-provision service)) + (match (service-user-groups service) + ((group) + (user-group-id group))))) + (operating-system-services os))) (populate -> `((directory "/nix/store" 0 ,build-user-gid) (directory "/etc") (directory "/var/log") ; for dmd (directory "/var/run/nscd") (directory "/var/nix/gcroots") - ("/var/nix/gcroots/default-profile" -> ,profile) + ("/var/nix/gcroots/system" -> ,os-dir) (directory "/tmp") (directory "/var/nix/profiles/per-user/root" 0 0) (directory "/var/nix/profiles/per-user/guest" 1000 100) - (directory "/home/guest" 1000 100))) - (boot (text-file "boot" (object->string - `(execl ,dmd-file "dmd" - "--config" ,dmd-conf)))) - (entries -> (list (return (menu-entry - (label (string-append - "GNU system with Linux-Libre " - (package-version linux-libre) - " (technology preview)")) - (linux linux-libre) - (linux-arguments `("--root=/dev/vda1" - ,(string-append "--load=" boot))) - (initrd gnu-system-initrd))))) - (grub.cfg (grub-configuration-file entries))) + (directory "/home/guest" 1000 100)))) (qemu-image #:grub-configuration grub.cfg #:populate populate #:disk-image-size (* 550 (expt 2 20)) #:initialize-store? #t - #:inputs-to-copy `(("boot" ,boot) - ("linux" ,linux-libre) - ("initrd" ,gnu-system-initrd) - ("dmd.conf" ,dmd-conf) - ("profile" ,profile-drv) - ("etc" ,etc-drv) - ,@(append-map service-inputs - services))))) + #:inputs-to-copy `(("system" ,os-drv))))) ;;; vm.scm ends here |