aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/activation.scm17
-rw-r--r--gnu/build/install.scm97
-rw-r--r--gnu/build/linux-initrd.scm30
-rw-r--r--gnu/build/linux-modules.scm4
-rw-r--r--gnu/build/marionette.scm28
-rw-r--r--gnu/build/vm.scm19
6 files changed, 132 insertions, 63 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 68ecd6bc71..0e77677de1 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -148,11 +148,15 @@ properties. Return #t on success."
`("-G" ,(string-join supplementary-groups ","))
'())
,@(if comment `("-c" ,comment) '())
- ,@(if (and home create-home?)
- (if (file-exists? home)
- `("-d" ,home) ; avoid warning from 'useradd'
- `("-d" ,home "--create-home"))
+ ,@(if home `("-d" ,home) '())
+
+ ;; Home directories of non-system accounts are created by
+ ;; 'activate-user-home'.
+ ,@(if (and home create-home? system?
+ (not (file-exists? home)))
+ '("--create-home")
'())
+
,@(if shell `("-s" ,shell) '())
,@(if password `("-p" ,password) '())
,@(if system? '("--system") '())
@@ -229,10 +233,7 @@ numeric gid or #f."
#:supplementary-groups supplementary-groups
#:comment comment
#:home home
-
- ;; Home directories of non-system accounts are created by
- ;; 'activate-user-home'.
- #:create-home? (and create-home? system?)
+ #:create-home? create-home?
#:shell shell
#:password password)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 5a5e703872..c9ebe124fe 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -18,7 +18,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build install)
- #:use-module (guix store database)
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (srfi srfi-26)
@@ -27,6 +26,7 @@
evaluate-populate-directive
populate-root-file-system
register-closure
+ install-database-and-gc-roots
populate-single-profile-directory))
;;; Commentary:
@@ -141,41 +141,53 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM."
(try))
(apply throw args)))))))
-(define* (register-closure prefix closure
- #:key
- (deduplicate? #t) (reset-timestamps? #t)
- (schema (sql-schema)))
- "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
-target store and CLOSURE is the name of a file containing a reference graph as
-produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
-true, reset timestamps on store files and, if DEDUPLICATE? is true,
-deduplicates files common to CLOSURE and the rest of PREFIX."
- (let ((items (call-with-input-file closure read-reference-graph)))
- (register-items items
- #:prefix prefix
- #:deduplicate? deduplicate?
- #:reset-timestamps? reset-timestamps?
- #:registration-time %epoch
- #:schema schema)))
+(define %root-profile
+ "/var/guix/profiles/per-user/root")
+
+(define* (install-database-and-gc-roots root database profile
+ #:key (profile-name "guix-profile"))
+ "Install DATABASE, the store database, under directory ROOT. Create
+PROFILE-NAME and have it link to PROFILE, a store item."
+ (define (scope file)
+ (string-append root "/" file))
+
+ (define (mkdir-p* dir)
+ (mkdir-p (scope dir)))
+
+ (define (symlink* old new)
+ (symlink old (scope new)))
+
+ (install-file database (scope "/var/guix/db/"))
+ (chmod (scope "/var/guix/db/db.sqlite") #o644)
+ (mkdir-p* "/var/guix/profiles")
+ (mkdir-p* "/var/guix/gcroots")
+ (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
+
+ ;; Make root's profile, which makes it a GC root.
+ (mkdir-p* %root-profile)
+ (symlink* profile
+ (string-append %root-profile "/" profile-name "-1-link"))
+ (symlink* (string-append profile-name "-1-link")
+ (string-append %root-profile "/" profile-name)))
(define* (populate-single-profile-directory directory
#:key profile closure
- deduplicate?
- register? schema)
+ (profile-name "guix-profile")
+ database)
"Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE.
-When REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the
-contents of the store; DEDUPLICATE? determines whether to deduplicate files in
-the store.
+
+When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
+DIRECTORY/var/guix/gcroots and friends.
+
+PROFILE-NAME is the name of the profile being created under
+/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
This is used to create the self-contained tarballs with 'guix pack'."
(define (scope file)
(string-append directory "/" file))
- (define %root-profile
- "/var/guix/profiles/per-user/root")
-
(define (mkdir-p* dir)
(mkdir-p (scope dir)))
@@ -185,25 +197,20 @@ This is used to create the self-contained tarballs with 'guix pack'."
;; Populate the store.
(populate-store (list closure) directory)
- (when register?
- (register-closure (canonicalize-path directory) closure
- #:deduplicate? deduplicate?
- #:schema schema)
-
- (mkdir-p* "/var/guix/profiles")
- (mkdir-p* "/var/guix/gcroots")
- (symlink* "/var/guix/profiles"
- "/var/guix/gcroots/profiles"))
-
- ;; Make root's profile, which makes it a GC root.
- (mkdir-p* %root-profile)
- (symlink* profile
- (string-append %root-profile "/guix-profile-1-link"))
- (symlink* (string-append %root-profile "/guix-profile-1-link")
- (string-append %root-profile "/guix-profile"))
-
- (mkdir-p* "/root")
- (symlink* (string-append %root-profile "/guix-profile")
- "/root/.guix-profile"))
+ (when database
+ (install-database-and-gc-roots directory database profile
+ #:profile-name profile-name))
+
+ (match profile-name
+ ("guix-profile"
+ (mkdir-p* "/root")
+ (symlink* (string-append %root-profile "/guix-profile")
+ "/root/.guix-profile"))
+ ("current-guix"
+ (mkdir-p* "/root/.config/guix")
+ (symlink* (string-append %root-profile "/current-guix")
+ "/root/.config/guix/current"))
+ (_
+ #t)))
;;; install.scm ends here
diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index c65b5aacfa..3aaa06d3a0 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -72,11 +72,23 @@ COMPRESS? is true, compress it using GZIP. On success, return OUTPUT."
#:file->header cpio:file->cpio-header*)))
(or (not compress?)
- ;; Use '--no-name' so that gzip records neither a file name nor a time
- ;; stamp in its output.
- (and (zero? (system* gzip "--best" "--no-name" output))
- (rename-file (string-append output ".gz")
- output))
+
+ ;; Gzip insists on adding a '.gz' suffix and does nothing if the input
+ ;; file already has that suffix. Shuffle files around to placate it.
+ (let* ((gz-suffix? (string-suffix? ".gz" output))
+ (sans-gz (if gz-suffix?
+ (string-drop-right output 3)
+ output)))
+ (when gz-suffix?
+ (rename-file output sans-gz))
+ ;; Use '--no-name' so that gzip records neither a file name nor a time
+ ;; stamp in its output.
+ (and (zero? (system* gzip "--best" "--no-name" sans-gz))
+ (begin
+ (unless gz-suffix?
+ (rename-file (string-append output ".gz") output))
+ output)))
+
output))
(define (cache-compiled-file-name file)
@@ -139,6 +151,12 @@ REFERENCES-GRAPHS."
(write-cpio-archive output "." #:gzip gzip))
+ ;; Make sure directories are writable so we can delete files.
+ (for-each make-file-writable
+ (find-files "contents"
+ (lambda (file stat)
+ (eq? 'directory (stat:type stat)))
+ #:directories? #t))
(delete-file-recursively "contents"))
;;; linux-initrd.scm ends here
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index ae141b6f54..2d81175041 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -136,7 +136,7 @@ and normalizing it."
(define (find-module-file directory module)
"Lookup module NAME under DIRECTORY, and return its absolute file name.
NAME can be a file name with or without '.ko', or it can be a module name.
-Return #f if it could not be found.
+Raise an error if it could not be found.
Module names can differ from file names in interesting ways; for instance,
module names usually (always?) use underscores as the inter-word separator,
@@ -162,7 +162,7 @@ whereas file names often, but not always, use hyphens. Examples:
((file)
file)
(()
- #f)
+ (error "kernel module not found" module directory))
((_ ...)
(error "several modules by that name" module directory))))
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index bb018fc9c1..f94eab5cc0 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,6 +28,7 @@
marionette-eval
wait-for-file
wait-for-tcp-port
+ wait-for-unix-socket
marionette-control
marionette-screen-text
wait-for-screen-text
@@ -214,6 +216,29 @@ MARIONETTE. Raise an error on failure."
('failure
(error "nobody's listening on port" port))))
+(define* (wait-for-unix-socket file-name marionette
+ #:key (timeout 20))
+ "Wait for up to TIMEOUT seconds for FILE-NAME, a Unix domain socket, to
+accept connections in MARIONETTE. Raise an error on failure."
+ (match (marionette-eval
+ `(begin
+ (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+ (let loop ((i 0))
+ (catch 'system-error
+ (lambda ()
+ (connect sock AF_UNIX ,file-name)
+ 'success)
+ (lambda args
+ (if (< i ,timeout)
+ (begin
+ (sleep 1)
+ (loop (+ 1 i)))
+ 'failure))))))
+ marionette)
+ ('success #t)
+ ('failure
+ (error "nobody's listening on unix domain socket" file-name))))
+
(define (marionette-control command marionette)
"Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as
\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)
@@ -222,7 +247,8 @@ pcsys_monitor\")."
(($ <marionette> _ _ monitor)
(display command monitor)
(newline monitor)
- (wait-for-monitor-prompt monitor))))
+ ;; The "quit" command terminates QEMU immediately, with no output.
+ (unless (string=? command "quit") (wait-for-monitor-prompt monitor)))))
(define* (marionette-screen-text marionette
#:key
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 5579886264..746808515f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -25,7 +25,7 @@
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (guix build syscalls)
- #:use-module ((guix store database) #:select (reset-timestamps))
+ #:use-module (guix store database)
#:use-module (gnu build linux-boot)
#:use-module (gnu build install)
#:use-module (gnu system uuid)
@@ -191,6 +191,23 @@ the #:references-graphs parameter of 'derivation'."
(mkdir output)
(copy-recursively "xchg" output)))))
+(define* (register-closure prefix closure
+ #:key
+ (deduplicate? #t) (reset-timestamps? #t)
+ (schema (sql-schema)))
+ "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
+target store and CLOSURE is the name of a file containing a reference graph as
+produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
+true, reset timestamps on store files and, if DEDUPLICATE? is true,
+deduplicates files common to CLOSURE and the rest of PREFIX."
+ (let ((items (call-with-input-file closure read-reference-graph)))
+ (register-items items
+ #:prefix prefix
+ #:deduplicate? deduplicate?
+ #:reset-timestamps? reset-timestamps?
+ #:registration-time %epoch
+ #:schema schema)))
+
;;;
;;; Partitions.
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-28 06:48:30 +0000