summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/dmd.scm67
-rw-r--r--gnu/system/linux.scm13
-rw-r--r--gnu/system/vm.scm202
3 files changed, 246 insertions, 36 deletions
diff --git a/gnu/system/dmd.scm b/gnu/system/dmd.scm
index 1e8767e357..b248d9f0c5 100644
--- a/gnu/system/dmd.scm
+++ b/gnu/system/dmd.scm
@@ -21,8 +21,12 @@
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix records)
+ #:use-module ((gnu packages base)
+ #:select (glibc-final))
#:use-module ((gnu packages system)
#:select (mingetty inetutils))
+ #:use-module ((gnu packages package-management)
+ #:select (guix))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (service?
@@ -34,8 +38,13 @@
service-stop
service-inputs
+ host-name-service
syslog-service
mingetty-service
+ nscd-service
+ guix-service
+ static-networking-service
+
dmd-configuration-file))
;;; Commentary:
@@ -58,6 +67,14 @@
(inputs service-inputs ; list of inputs
(default '())))
+(define (host-name-service store name)
+ "Return a service that sets the host name to NAME."
+ (service
+ (provision '(host-name))
+ (start `(lambda _
+ (sethostname ,name)))
+ (respawn? #f)))
+
(define (mingetty-service store tty)
"Return a service to run mingetty on TTY."
(let* ((mingetty-drv (package-derivation store mingetty))
@@ -65,9 +82,32 @@
"/sbin/mingetty")))
(service
(provision (list (symbol-append 'term- (string->symbol tty))))
+
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done.
+ (requirement '(host-name))
+
(start `(make-forkexec-constructor ,mingetty-bin "--noclear" ,tty))
(inputs `(("mingetty" ,mingetty))))))
+(define* (nscd-service store
+ #:key (glibc glibc-final))
+ "Return a service that runs libc's name service cache daemon (nscd)."
+ (let ((nscd (string-append (package-output store glibc) "/sbin/nscd")))
+ (service
+ (provision '(nscd))
+ (start `(make-forkexec-constructor ,nscd "-f" "/dev/null"))
+
+ ;; XXX: Local copy of 'make-kill-destructor' because the one upstream
+ ;; uses the broken 'opt-lambda' macro.
+ (stop `(lambda* (#:optional (signal SIGTERM))
+ (lambda (pid . args)
+ (kill pid signal)
+ #f)))
+
+ (respawn? #f)
+ (inputs `(("glibc" ,glibc))))))
+
(define (syslog-service store)
"Return a service that runs 'syslogd' with reasonable default settings."
@@ -104,6 +144,33 @@
(inputs `(("inetutils" ,inetutils)
("syslog.conf" ,syslog.conf))))))
+(define* (guix-service store #:key (guix guix))
+ "Return a service that runs the build daemon from GUIX."
+ (let* ((drv (package-derivation store guix))
+ (daemon (string-append (derivation->output-path drv)
+ "/bin/guix-daemon")))
+ (service
+ (provision '(guix-daemon))
+ (start `(make-forkexec-constructor ,daemon))
+ (inputs `(("guix" ,guix))))))
+
+(define* (static-networking-service store interface ip
+ #:key (inetutils inetutils))
+ "Return a service that starts INTERFACE with address IP."
+
+ ;; TODO: Eventually we should do this using Guile's networking procedures,
+ ;; like 'configure-qemu-networking' does, but the patch that does this is
+ ;; not yet in stock Guile.
+ (let ((ifconfig (string-append (package-output store inetutils)
+ "/bin/ifconfig")))
+ (service
+ (provision '(networking))
+ (start `(make-forkexec-constructor ,ifconfig ,interface ,ip "up"))
+ (stop `(make-forkexec-constructor ,ifconfig ,interface "down"))
+ (respawn? #f)
+ (inputs `(("inetutils" ,inetutils))))))
+
+
(define (dmd-configuration-file store services)
"Return the dmd configuration file for SERVICES."
(define config
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index b2daa13e06..6aebe159ba 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -125,9 +125,10 @@
(let ((unix (pam-entry
(control "required")
(module "pam_unix.so"))))
- (lambda* (name #:key allow-empty-passwords?)
+ (lambda* (name #:key allow-empty-passwords? motd)
"Return a standard Unix-style PAM service for NAME. When
-ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
+ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords. When MOTD is true, it
+should be the name of a file used as the message-of-the-day."
;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
(let ((name* name))
(pam-service
@@ -140,6 +141,12 @@ ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords."
(arguments '("nullok")))
unix)))
(password (list unix))
- (session (list unix)))))))
+ (session (if motd
+ (list unix
+ (pam-entry
+ (control "optional")
+ (module "pam_motd.so")
+ (arguments (list (string-append "motd=" motd)))))
+ (list unix))))))))
;;; linux.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index df55f7c94e..0ed805510a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,8 @@
#:use-module (guix packages)
#:use-module ((gnu packages base) #:select (%final-inputs
guile-final
+ gcc-final
+ glibc-final
coreutils))
#:use-module (gnu packages guile)
#:use-module (gnu packages bash)
@@ -31,6 +33,7 @@
#:use-module (gnu packages grub)
#:use-module (gnu packages linux)
#:use-module (gnu packages linux-initrd)
+ #:use-module (gnu packages package-management)
#:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped))
#:use-module (gnu packages system)
@@ -91,6 +94,10 @@ made available under the /xchg CIFS share."
`(,input . ,(package-output store package "out" system)))
((input (? package? package) sub-drv)
`(,input . ,(package-output store package sub-drv system)))
+ ((input (? derivation? drv))
+ `(,input . ,(derivation->output-path drv)))
+ ((input (? derivation? drv) sub-drv)
+ `(,input . ,(derivation->output-path drv sub-drv)))
((input (and (? string?) (? store-path?) file))
`(,input . ,file)))
inputs))
@@ -177,7 +184,8 @@ made available under the /xchg CIFS share."
`(,name ,(->drv package)
,@sub-drv))
((name (? string? file))
- `(,name ,file)))
+ `(,name ,file))
+ (tuple tuple))
inputs))
#:env-vars env-vars
#:modules (delete-duplicates
@@ -191,6 +199,7 @@ made available under the /xchg CIFS share."
(system (%current-system))
(disk-image-size (* 100 (expt 2 20)))
grub-configuration
+ (initialize-store? #f)
(populate #f)
(inputs '())
(inputs-to-copy '()))
@@ -199,11 +208,13 @@ disk image, with a GRUB installation that uses GRUB-CONFIGURATION as its
configuration file.
INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
-into the image being built.
+into the image being built. When INITIALIZE-STORE? is true, initialize the
+store database in the image so that Guix can be used in the image.
-When POPULATE is true, it must be the store file name of a Guile script to run
-in the disk image partition once it has been populated with INPUTS-TO-COPY.
-It can be used to provide additional files, such as /etc files."
+POPULATE is a list of directives stating directories or symlinks to be created
+in the disk image partition. It is evaluated once the image has been
+populated with INPUTS-TO-COPY. It can be used to provide additional files,
+such as /etc files."
(define input->name+derivation
(match-lambda
((name (? package? package))
@@ -213,6 +224,10 @@ It can be used to provide additional files, such as /etc files."
`(,name . ,(derivation->output-path
(package-derivation store package system)
sub-drv)))
+ ((name (? derivation? drv))
+ `(,name . ,(derivation->output-path drv)))
+ ((name (? derivation? drv) sub-drv)
+ `(,name . ,(derivation->output-path drv sub-drv)))
((input (and (? string?) (? store-path?) file))
`(,input . ,file))))
@@ -298,6 +313,36 @@ It can be used to provide additional files, such as /etc files."
;; Populate /dev.
(make-essential-device-nodes #:root "/fs")
+ ;; Optionally, register the inputs in the image's store.
+ (let* ((guix (assoc-ref %build-inputs "guix"))
+ (register (string-append guix
+ "/sbin/guix-register")))
+ ,@(if initialize-store?
+ (match inputs-to-copy
+ (((graph-files . _) ...)
+ (map (lambda (closure)
+ `(system* register "--prefix" "/fs"
+ ,(string-append "/xchg/"
+ closure)))
+ graph-files)))
+ '(#f)))
+
+ ;; Evaluate the POPULATE directives.
+ ,@(let loop ((directives populate)
+ (statements '()))
+ (match directives
+ (()
+ (reverse statements))
+ ((('directory name) rest ...)
+ (loop rest
+ (cons `(mkdir-p ,(string-append "/fs" name))
+ statements)))
+ (((new '-> old) rest ...)
+ (loop rest
+ (cons `(symlink ,old
+ ,(string-append "/fs" new))
+ statements)))))
+
(and=> (assoc-ref %build-inputs "populate")
(lambda (populate)
(chdir "/fs")
@@ -337,8 +382,8 @@ It can be used to provide additional files, such as /etc files."
("gawk" ,(car (assoc-ref %final-inputs "gawk")))
("util-linux" ,util-linux)
- ,@(if populate
- `(("populate" ,populate))
+ ,@(if initialize-store?
+ `(("guix" ,guix-0.4))
'())
,@inputs-to-copy)
@@ -353,19 +398,73 @@ It can be used to provide additional files, such as /etc files."
;;; Stand-alone VM image.
;;;
+(define* (union store 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))))
+
+ (build-expression->derivation store name system builder
+ (map (match-lambda
+ ((name (? package? p))
+ `(,name ,(package-derivation store p
+ system)))
+ ((name (? package? p) output)
+ `(,name ,(package-derivation store p
+ system)
+ ,output))
+ (x x))
+ inputs)
+ #:modules '((guix build union))
+ #:guile-for-build guile))
+
(define (system-qemu-image store)
"Return the derivation of a QEMU image of the GNU system."
+ (define motd
+ (add-text-to-store store "motd" "
+Happy birthday, GNU! http://www.gnu.org/gnu30
+
+"))
+
(define %pam-services
;; Services known to PAM.
(list %pam-other-services
- (unix-pam-service "login" #:allow-empty-passwords? #t)))
+ (unix-pam-service "login"
+ #:allow-empty-passwords? #t
+ #:motd motd)))
(define %dmd-services
;; Services run by dmd.
- (list (mingetty-service store "tty1")
+ (list (host-name-service store "gnu")
+ (mingetty-service store "tty1")
(mingetty-service store "tty2")
(mingetty-service store "tty3")
- (syslog-service store)))
+ (mingetty-service store "tty4")
+ (mingetty-service store "tty5")
+ (mingetty-service store "tty6")
+ (syslog-service store)
+ (guix-service store #:guix guix-0.4)
+ (nscd-service store)
+
+ ;; QEMU networking settings.
+ (static-networking-service store "eth0" "10.0.2.10")))
+
+ (define resolv.conf
+ ;; Name resolution for default QEMU settings.
+ (add-text-to-store store "resolv.conf"
+ "nameserver 10.0.2.3\n"))
(parameterize ((%guile-for-build (package-derivation store guile-final)))
(let* ((bash-drv (package-derivation store bash))
@@ -383,20 +482,53 @@ It can be used to provide additional files, such as /etc files."
"root:x:0:\n"))
(pam.d-drv (pam-services->directory store %pam-services))
(pam.d (derivation->output-path pam.d-drv))
- (populate
- (add-text-to-store store "populate-qemu-image"
- (object->string
- `(begin
- (mkdir-p "etc")
- (mkdir-p "var/log") ; for dmd
- (symlink ,shadow "etc/shadow")
- (symlink ,passwd "etc/passwd")
- (symlink ,group "etc/group")
- (symlink "/dev/null"
- "etc/login.defs")
- (symlink ,pam.d "etc/pam.d")
- (mkdir-p "var/run")))
- (list passwd)))
+
+ (packages `(("coreutils" ,coreutils)
+ ("bash" ,bash)
+ ("guile" ,guile-2.0)
+ ("dmd" ,dmd)
+ ("gcc" ,gcc-final)
+ ("libc" ,glibc-final)
+ ("inetutils" ,inetutils)
+ ("guix" ,guix-0.4)))
+
+ ;; TODO: Replace with a real profile with a manifest.
+ ;; TODO: Generate bashrc from packages' search-paths.
+ (profile-drv (union store packages
+ #:name "default-profile"))
+ (profile (derivation->output-path profile-drv))
+ (bashrc (add-text-to-store store "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'
+")))
+
+ (issue (add-text-to-store store "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 'root' with no password.
+"))
+
+ (populate `((directory "/etc")
+ (directory "/var/log") ; for dmd
+ (directory "/var/run/nscd")
+ ("/etc/shadow" -> ,shadow)
+ ("/etc/passwd" -> ,passwd)
+ ("/etc/login.defs" -> "/dev/null")
+ ("/etc/pam.d" -> ,pam.d)
+ ("/etc/resolv.conf" -> ,resolv.conf)
+ ("/etc/profile" -> ,bashrc)
+ ("/etc/issue" -> ,issue)
+ (directory "/var/nix/gcroots")
+ ("/var/nix/gcroots/default-profile" -> ,profile)))
(out (derivation->output-path
(package-derivation store mingetty)))
(boot (add-text-to-store store "boot"
@@ -405,32 +537,36 @@ It can be used to provide additional files, such as /etc files."
"--config" ,dmd-conf))
(list out)))
(entries (list (menu-entry
- (label "Boot-to-Guile! (GNU System technology preview)")
+ (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 store entries)))
- (build-derivations store (list pam.d-drv))
(qemu-image store
#:grub-configuration grub.cfg
#:populate populate
- #:disk-image-size (* 400 (expt 2 20))
+ #:disk-image-size (* 500 (expt 2 20))
+ #:initialize-store? #t
#:inputs-to-copy `(("boot" ,boot)
("linux" ,linux-libre)
("initrd" ,gnu-system-initrd)
- ("coreutils" ,coreutils)
- ("bash" ,bash)
- ("guile" ,guile-2.0)
- ("mingetty" ,mingetty)
- ("dmd" ,dmd)
+ ("pam.d" ,pam.d-drv)
+ ("profile" ,profile-drv)
;; Configuration.
("dmd.conf" ,dmd-conf)
- ("etc-pam.d" ,pam.d)
+ ("etc-pam.d" ,pam.d-drv)
("etc-passwd" ,passwd)
("etc-shadow" ,shadow)
("etc-group" ,group)
+ ("etc-resolv.conf" ,resolv.conf)
+ ("etc-bashrc" ,bashrc)
+ ("etc-issue" ,issue)
+ ("etc-motd" ,motd)
,@(append-map service-inputs
%dmd-services))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-17 04:42:32 +0000