summaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/file-systems.scm90
-rw-r--r--gnu/build/install.scm44
-rw-r--r--gnu/build/linux-container.scm3
-rw-r--r--gnu/build/linux-modules.scm115
-rw-r--r--gnu/build/secret-service.scm137
-rw-r--r--gnu/build/shepherd.scm18
6 files changed, 345 insertions, 62 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index ad92d8a496..4ba1503b9f 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -478,6 +478,42 @@ not valid header was found."
;;;
+;;; NTFS file systems.
+;;;
+
+;; Taken from <linux-libre>/fs/ntfs/layout.h
+
+(define-syntax %ntfs-endianness
+ ;; Endianness of NTFS file systems.
+ (identifier-syntax (endianness little)))
+
+(define (ntfs-superblock? sblock)
+ "Return #t when SBLOCK is a NTFS superblock."
+ (bytevector=? (sub-bytevector sblock 3 8)
+ (string->utf8 "NTFS ")))
+
+(define (read-ntfs-superblock device)
+ "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f
+if DEVICE does not contain a NTFS file system."
+ (read-superblock device 0 511 ntfs-superblock?))
+
+(define (ntfs-superblock-uuid sblock)
+ "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector."
+ (sub-bytevector sblock 72 8))
+
+;; TODO: Add ntfs-superblock-volume-name. The partition label is not stored
+;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems
+;; way harder to access.
+
+(define (check-ntfs-file-system device)
+ "Return the health of a NTFS file system on DEVICE."
+ (match (status:exit-val
+ (system* "ntfsfix" device))
+ (0 'pass)
+ (_ 'fatal-error)))
+
+
+;;;
;;; Partition lookup.
;;;
@@ -585,7 +621,9 @@ partition field reader that returned a value."
(partition-field-reader read-jfs-superblock
jfs-superblock-uuid)
(partition-field-reader read-f2fs-superblock
- f2fs-superblock-uuid)))
+ f2fs-superblock-uuid)
+ (partition-field-reader read-ntfs-superblock
+ ntfs-superblock-uuid)))
(define read-partition-label
(cut read-partition-field <> %partition-label-readers))
@@ -684,6 +722,7 @@ were found."
((string-suffix? "fat" type) check-fat-file-system)
((string-prefix? "jfs" type) check-jfs-file-system)
((string-prefix? "f2fs" type) check-f2fs-file-system)
+ ((string-prefix? "ntfs" type) check-ntfs-file-system)
((string-prefix? "nfs" type) (const 'pass))
(else #f)))
@@ -775,26 +814,33 @@ corresponds to the symbols listed in FLAGS."
(when (file-system-check? fs)
(check-file-system source type))
- ;; Create the mount point. Most of the time this is a directory, but
- ;; in the case of a bind mount, a regular file or socket may be needed.
- (if (and (= MS_BIND (logand flags MS_BIND))
- (not (file-is-directory? source)))
- (unless (file-exists? mount-point)
- (mkdir-p (dirname mount-point))
- (call-with-output-file mount-point (const #t)))
- (mkdir-p mount-point))
-
- (cond
- ((string-prefix? "nfs" type)
- (mount-nfs source mount-point type flags options))
- (else
- (mount source mount-point type flags options)))
-
- ;; For read-only bind mounts, an extra remount is needed, as per
- ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
- (when (and (= MS_BIND (logand flags MS_BIND))
- (= MS_RDONLY (logand flags MS_RDONLY)))
- (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
- (mount source mount-point type flags #f)))))
+ (catch 'system-error
+ (lambda ()
+ ;; Create the mount point. Most of the time this is a directory, but
+ ;; in the case of a bind mount, a regular file or socket may be
+ ;; needed.
+ (if (and (= MS_BIND (logand flags MS_BIND))
+ (not (file-is-directory? source)))
+ (unless (file-exists? mount-point)
+ (mkdir-p (dirname mount-point))
+ (call-with-output-file mount-point (const #t)))
+ (mkdir-p mount-point))
+
+ (cond
+ ((string-prefix? "nfs" type)
+ (mount-nfs source mount-point type flags options))
+ (else
+ (mount source mount-point type flags options)))
+
+ ;; For read-only bind mounts, an extra remount is needed, as per
+ ;; <http://lwn.net/Articles/281157/>, which still applies to Linux
+ ;; 4.0.
+ (when (and (= MS_BIND (logand flags MS_BIND))
+ (= MS_RDONLY (logand flags MS_RDONLY)))
+ (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
+ (mount source mount-point type flags #f))))
+ (lambda args
+ (or (file-system-mount-may-fail? fs)
+ (apply throw args))))))
;;; file-systems.scm ends here
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index 87aa5d68da..63995e1d09 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -18,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build install)
+ #:use-module (guix build syscalls)
#:use-module (guix build utils)
#:use-module (guix build store-copy)
#:use-module (srfi srfi-26)
@@ -26,7 +27,9 @@
evaluate-populate-directive
populate-root-file-system
install-database-and-gc-roots
- populate-single-profile-directory))
+ populate-single-profile-directory
+ mount-cow-store
+ unmount-cow-store))
;;; Commentary:
;;;
@@ -229,4 +232,43 @@ This is used to create the self-contained tarballs with 'guix pack'."
(_
#t)))
+(define (mount-cow-store target backing-directory)
+ "Make the store copy-on-write, using TARGET as the backing store. This is
+useful when TARGET is on a hard disk, whereas the current store is on a RAM
+disk."
+ (define (set-store-permissions directory)
+ "Set the right perms on DIRECTORY to use it as the store."
+ (chown directory 0 30000) ;use the fixed 'guixbuild' GID
+ (chmod directory #o1775))
+
+ (let ((tmpdir (string-append target "/tmp")))
+ (mkdir-p tmpdir)
+ (mount tmpdir "/tmp" "none" MS_BIND))
+
+ (let* ((rw-dir (string-append target backing-directory))
+ (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
+ (mkdir-p rw-dir)
+ (mkdir-p work-dir)
+ (mkdir-p "/.rw-store")
+ (set-store-permissions rw-dir)
+ (set-store-permissions "/.rw-store")
+
+ ;; Mount the overlay, then atomically make it the store.
+ (mount "none" "/.rw-store" "overlay" 0
+ (string-append "lowerdir=" (%store-directory) ","
+ "upperdir=" rw-dir ","
+ "workdir=" work-dir))
+ (mount "/.rw-store" (%store-directory) "" MS_MOVE)
+ (rmdir "/.rw-store")))
+
+(define (unmount-cow-store target backing-directory)
+ "Unmount copy-on-write store."
+ (let ((tmp-dir "/remove"))
+ (mkdir-p tmp-dir)
+ (mount (%store-directory) tmp-dir "" MS_MOVE)
+ (umount tmp-dir)
+ (rmdir tmp-dir)
+ (delete-file-recursively
+ (string-append target backing-directory))))
+
;;; install.scm ends here
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 87695c98fd..21292b8d2f 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -243,7 +243,8 @@ that host UIDs (respectively GIDs) map to in the namespace."
(match (read child)
('ready
(purify-environment)
- (when (memq 'mnt namespaces)
+ (when (and (not (null? mounts))
+ (memq 'mnt namespaces))
(catch #t
(lambda ()
(mount-file-systems root mounts
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index aa1c7cfeae..3a47322065 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -24,6 +24,7 @@
#:use-module (guix build syscalls)
#:use-module ((guix build utils) #:select (find-files invoke))
#:use-module (guix build union)
+ #:autoload (zlib) (call-with-gzip-input-port)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -94,10 +95,28 @@ string list."
(cons (string->symbol (string-take str =))
(string-drop str (+ 1 =)))))
+;; Matches kernel modules, without compression, with GZIP compression or with
+;; XZ compression.
+(define module-regex "\\.ko(\\.gz|\\.xz)?$")
+
(define (modinfo-section-contents file)
"Return the contents of the '.modinfo' section of FILE as a list of
key/value pairs.."
- (let* ((bv (call-with-input-file file get-bytevector-all))
+ (define (get-bytevector file)
+ (cond
+ ((string-suffix? ".ko.gz" file)
+ (let ((port (open-file file "r0")))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ (call-with-gzip-input-port port get-bytevector-all))
+ (lambda ()
+ (close-port port)))))
+ (else
+ (call-with-input-file file get-bytevector-all))))
+
+ (let* ((bv (get-bytevector file))
(elf (parse-elf bv))
(section (elf-section-by-name elf ".modinfo"))
(modinfo (section-contents elf section)))
@@ -110,7 +129,7 @@ key/value pairs.."
(define (module-formal-name file)
"Return the module name of FILE as it appears in its info section. Usually
the module name is the same as the base name of FILE, modulo hyphens and minus
-the \".ko\" extension."
+the \".ko[.gz|.xz]\" extension."
(match (assq 'name (modinfo-section-contents file))
(('name . name) name)
(#f #f)))
@@ -171,14 +190,25 @@ modules that can be postloaded, of the soft dependencies of module FILE."
(_ #f))
(modinfo-section-contents file))))
-(define dot-ko
- (cut string-append <> ".ko"))
-
-(define (ensure-dot-ko name)
- "Return NAME with a '.ko' prefix appended, unless it already has it."
- (if (string-suffix? ".ko" name)
+(define (strip-extension filename)
+ (let ((extension (string-index filename #\.)))
+ (if extension
+ (string-take filename extension)
+ filename)))
+
+(define (dot-ko name compression)
+ (let ((suffix (match compression
+ ('xz ".ko.xz")
+ ('gzip ".ko.gz")
+ (else ".ko"))))
+ (string-append name suffix)))
+
+(define (ensure-dot-ko name compression)
+ "Return NAME with a '.ko[.gz|.xz]' suffix appended, unless it already has
+it."
+ (if (string-contains name ".ko")
name
- (dot-ko name)))
+ (dot-ko name compression)))
(define (normalize-module-name module)
"Return the \"canonical\" name for MODULE, replacing hyphens with
@@ -191,9 +221,9 @@ underscores."
module))
(define (file-name->module-name file)
- "Return the module name corresponding to FILE, stripping the trailing '.ko'
-and normalizing it."
- (normalize-module-name (basename file ".ko")))
+ "Return the module name corresponding to FILE, stripping the trailing
+'.ko[.gz|.xz]' and normalizing it."
+ (normalize-module-name (strip-extension (basename file))))
(define (find-module-file directory module)
"Lookup module NAME under DIRECTORY, and return its absolute file name.
@@ -208,19 +238,19 @@ whereas file names often, but not always, use hyphens. Examples:
;; List of possible file names. XXX: It would of course be cleaner to
;; have a database that maps module names to file names and vice versa,
;; but everyone seems to be doing hacks like this one. Oh well!
- (map ensure-dot-ko
- (delete-duplicates
- (list module
- (normalize-module-name module)
- (string-map (lambda (chr) ;converse of 'normalize-module-name'
- (case chr
- ((#\_) #\-)
- (else chr)))
- module)))))
+ (delete-duplicates
+ (list module
+ (normalize-module-name module)
+ (string-map (lambda (chr) ;converse of 'normalize-module-name'
+ (case chr
+ ((#\_) #\-)
+ (else chr)))
+ module))))
(match (find-files directory
(lambda (file stat)
- (member (basename file) names)))
+ (member (strip-extension
+ (basename file)) names)))
((file)
file)
(()
@@ -290,8 +320,8 @@ not a file name."
(recursive? #t)
(lookup-module dot-ko)
(black-list (module-black-list)))
- "Load Linux module from FILE, the name of a '.ko' file; return true on
-success, false otherwise. When RECURSIVE? is true, load its dependencies
+ "Load Linux module from FILE, the name of a '.ko[.gz|.xz]' file; return true
+on success, false otherwise. When RECURSIVE? is true, load its dependencies
first (à la 'modprobe'.) The actual files containing modules depended on are
obtained by calling LOOKUP-MODULE with the module name. Modules whose name
appears in BLACK-LIST are not loaded."
@@ -523,16 +553,29 @@ are required to access DEVICE."
;;; Module databases.
;;;
-(define (module-name->file-name/guess directory name)
+(define* (module-name->file-name/guess directory name
+ #:key compression)
"Guess the file name corresponding to NAME, a module name. That doesn't
always work because sometimes underscores in NAME map to hyphens (e.g.,
-\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")."
- (string-append directory "/" (ensure-dot-ko name)))
+\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\"). If the module is
+compressed then COMPRESSED can be set to 'xz or 'gzip, depending on the
+compression type."
+ (string-append directory "/" (ensure-dot-ko name compression)))
(define (module-name-lookup directory)
"Return a one argument procedure that takes a module name (e.g.,
\"input_leds\") and returns its absolute file name (e.g.,
\"/.../input-leds.ko\")."
+ (define (guess-file-name name)
+ (let ((names (list
+ (module-name->file-name/guess directory name)
+ (module-name->file-name/guess directory name
+ #:compression 'xz)
+ (module-name->file-name/guess directory name
+ #:compression 'gzip))))
+ (or (find file-exists? names)
+ (first names))))
+
(catch 'system-error
(lambda ()
(define mapping
@@ -541,23 +584,23 @@ always work because sometimes underscores in NAME map to hyphens (e.g.,
(lambda (name)
(or (assoc-ref mapping name)
- (module-name->file-name/guess directory name))))
+ (guess-file-name name))))
(lambda args
(if (= ENOENT (system-error-errno args))
- (cut module-name->file-name/guess directory <>)
+ (cut guess-file-name <>)
(apply throw args)))))
(define (write-module-name-database directory)
"Write a database that maps \"module names\" as they appear in the relevant
-ELF section of '.ko' files, to actual file names. This format is
+ELF section of '.ko[.gz|.xz]' files, to actual file names. This format is
Guix-specific. It aims to deal with inconsistent naming, in particular
hyphens vs. underscores."
(define mapping
(map (lambda (file)
(match (module-formal-name file)
- (#f (cons (basename file ".ko") file))
+ (#f (cons (strip-extension (basename file)) file))
(name (cons name file))))
- (find-files directory "\\.ko$")))
+ (find-files directory module-regex)))
(call-with-output-file (string-append directory "/modules.name")
(lambda (port)
@@ -569,12 +612,12 @@ hyphens vs. underscores."
(pretty-print mapping port))))
(define (write-module-alias-database directory)
- "Traverse the '.ko' files in DIRECTORY and create the corresponding
+ "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
'modules.alias' file."
(define aliases
(map (lambda (file)
(cons (file-name->module-name file) (module-aliases file)))
- (find-files directory "\\.ko$")))
+ (find-files directory module-regex)))
(call-with-output-file (string-append directory "/modules.alias")
(lambda (port)
@@ -616,7 +659,7 @@ are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
(char-set-complement (char-set #\-)))
(define (write-module-device-database directory)
- "Traverse the '.ko' files in DIRECTORY and create the corresponding
+ "Traverse the '.ko[.gz|.xz]' files in DIRECTORY and create the corresponding
'modules.devname' file. This file contains information about modules that can
be loaded on-demand, such as file system modules."
(define aliases
@@ -624,7 +667,7 @@ be loaded on-demand, such as file system modules."
(match (aliases->device-tuple (module-aliases file))
(#f #f)
(tuple (cons (file-name->module-name file) tuple))))
- (find-files directory "\\.ko$")))
+ (find-files directory module-regex)))
(call-with-output-file (string-append directory "/modules.devname")
(lambda (port)
diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
new file mode 100644
index 0000000000..781651e90d
--- /dev/null
+++ b/gnu/build/secret-service.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@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 build secret-service)
+ #:use-module (guix build utils)
+
+ #:use-module (srfi srfi-26)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+
+ #:export (secret-service-receive-secrets
+ secret-service-send-secrets))
+
+;;; Commentary:
+;;;
+;;; Utility procedures for copying secrets into a VM.
+;;;
+;;; Code:
+
+(define* (secret-service-send-secrets port secret-root #:key (retry 60))
+ "Copy all files under SECRET-ROOT using TCP to secret-service listening at
+local PORT. If connect fails, sleep 1s and retry RETRY times."
+
+ (define (file->file+size+mode file-name)
+ (let ((stat (stat file-name))
+ (target (substring file-name (string-length secret-root))))
+ (list target (stat:size stat) (stat:mode stat))))
+
+ (format (current-error-port) "sending secrets to ~a~%" port)
+ (let ((sock (socket AF_INET SOCK_STREAM 0))
+ (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
+ ;; connect to wait for port
+ (let loop ((retry retry))
+ (catch 'system-error
+ (cute connect sock addr)
+ (lambda (key . args)
+ (when (zero? retry)
+ (apply throw key args))
+ (format (current-error-port) "retrying connection~%")
+ (sleep 1)
+ (loop (1- retry)))))
+
+ (format (current-error-port) "connected! sending files in ~s %~"
+ secret-root)
+ (let* ((files (if secret-root (find-files secret-root) '()))
+ (files-sizes-modes (map file->file+size+mode files))
+ (secrets `(secrets
+ (version 0)
+ (files ,files-sizes-modes))))
+ (write secrets sock)
+ (for-each (compose (cute dump-port <> sock)
+ (cute open-input-file <>))
+ files))))
+
+(define (secret-service-receive-secrets port)
+ "Listen to local PORT and wait for a secret service client to send secrets.
+Write them to the file system."
+
+ (define (wait-for-client port)
+ ;; Wait for a TCP connection on PORT. Note: We cannot use the
+ ;; virtio-serial ports, which would be safer, because they are
+ ;; (presumably) unsupported on GNU/Hurd.
+ (let ((sock (socket AF_INET SOCK_STREAM 0)))
+ (bind sock AF_INET INADDR_ANY port)
+ (listen sock 1)
+ (format (current-error-port)
+ "waiting for secrets on port ~a...~%"
+ port)
+ (match (accept sock)
+ ((client . address)
+ (format (current-error-port) "client connection from ~a~%"
+ (inet-ntop (sockaddr:fam address)
+ (sockaddr:addr address)))
+ (close-port sock)
+ client))))
+
+ ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size'
+ ;; parameter.
+ (define (dump in out size)
+ ;; Copy SIZE bytes from IN to OUT.
+ (define buf-size 65536)
+ (define buf (make-bytevector buf-size))
+
+ (let loop ((left size))
+ (if (<= left 0)
+ 0
+ (let ((read (get-bytevector-n! in buf 0 (min left buf-size))))
+ (if (eof-object? read)
+ left
+ (begin
+ (put-bytevector out buf 0 read)
+ (loop (- left read))))))))
+
+ (define (read-secrets port)
+ ;; Read secret files from PORT and install them.
+ (match (false-if-exception (read port))
+ (('secrets ('version 0)
+ ('files ((files sizes modes) ...)))
+ (for-each (lambda (file size mode)
+ (format (current-error-port)
+ "installing file '~a' (~a bytes)...~%"
+ file size)
+ (mkdir-p (dirname file))
+ (call-with-output-file file
+ (lambda (output)
+ (dump port output size)
+ (chmod file mode))))
+ files sizes modes))
+ (_
+ (format (current-error-port)
+ "invalid secrets received~%")
+ #f)))
+
+ (let* ((port (wait-for-client port))
+ (result (read-secrets port)))
+ (close-port port)
+ result))
+
+;;; secret-service.scm ends here
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index fd93e7f3f4..65141bd60f 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -20,10 +20,12 @@
#:use-module (gnu system file-systems)
#:use-module (gnu build linux-container)
#:use-module (guix build utils)
+ #:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (make-forkexec-constructor/container))
+ #:export (make-forkexec-constructor/container
+ fork+exec-command/container))
;;; Commentary:
;;;
@@ -93,7 +95,8 @@
;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
(module-autoload! (current-module)
'(shepherd service)
- '(read-pid-file exec-command %precious-signals))
+ '(fork+exec-command read-pid-file exec-command
+ %precious-signals))
(module-autoload! (current-module)
'(shepherd system) '(unblock-signals))
@@ -188,6 +191,17 @@ namespace, in addition to essential bind-mounts such /proc."
(read-pid-file pid-file #:max-delay pid-file-timeout))
pid))))
+(define* (fork+exec-command/container command
+ #:key pid
+ #:allow-other-keys
+ #:rest args)
+ "This is a variant of 'fork+exec-command' procedure, that joins the
+namespaces of process PID beforehand."
+ (container-excursion* pid
+ (lambda ()
+ (apply fork+exec-command command
+ (strip-keyword-arguments '(#:pid) args)))))
+
;; Local Variables:
;; eval: (put 'container-excursion* 'scheme-indent-function 1)
;; End:
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-05 11:45:03 +0000