From 4138e782dcfea675ebc2347cbd4ea9abeb9dff36 Mon Sep 17 00:00:00 2001 From: Christopher Baines <mail@cbaines.net> Date: Sun, 3 Sep 2017 10:56:25 +0100 Subject: vm: Remove redundant conditional in system-disk-image. * gnu/system/vm.scm (system-disk-image): Remove redundant conditional for #:file-system-type when calling qemu-image. --- gnu/system/vm.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4494af0031..b3da118765 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -403,10 +403,7 @@ to USB sticks meant to be read-only." (operating-system-bootloader os)) #:disk-image-size disk-image-size #:disk-image-format "raw" - #:file-system-type (if (string=? "iso9660" - file-system-type) - "ext4" - file-system-type) + #:file-system-type file-system-type #:file-system-label root-label #:copy-inputs? #t #:register-closures? #t -- cgit v1.2.3 From e375d3fab7a64246f9c1caa4b23a280f5b84ebc6 Mon Sep 17 00:00:00 2001 From: Christopher Baines <mail@cbaines.net> Date: Sun, 3 Sep 2017 11:48:20 +0100 Subject: vm: Add support for registering closures to iso9660-image. * gnu/system/vm.scm (iso9660-image): Add support for registering closures. --- gnu/system/vm.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b3da118765..f7a711a72b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,6 +192,7 @@ made available under the /xchg CIFS share." os-drv bootcfg-drv bootloader + register-closures? (inputs '())) "Return a bootable, stand-alone iso9660 image. @@ -207,8 +208,13 @@ INPUTS is a list of inputs (as for packages)." (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools xorriso) (map canonical-package - (list sed grep coreutils findutils gawk)))) + (list sed grep coreutils findutils gawk)) + (if register-closures? (list guix) '()))) + + (graphs '#$(match inputs + (((names . _) ...) + names))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. (to-register @@ -222,6 +228,8 @@ INPUTS is a list of inputs (as for packages)." #$bootcfg-drv #$os-drv "/xchg/guixsd.iso" + #:register-closures? #$register-closures? + #:closures graphs #:volume-id #$file-system-label #:volume-uuid #$file-system-uuid) (reboot)))) -- cgit v1.2.3 From b069111f7a5d2c4596b9bc796fd0f56b77eb4c4e Mon Sep 17 00:00:00 2001 From: Christopher Baines <mail@cbaines.net> Date: Sun, 3 Sep 2017 11:48:27 +0100 Subject: vm: Call iso9660-image with #:register-closures? as #t. * gnu/system/vm.scm (system-disk-image): Call iso9660-image with #:register-closures? as #t. --- gnu/system/vm.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f7a711a72b..b106dff0a8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -399,6 +399,7 @@ to USB sticks meant to be read-only." #:file-system-label root-label #:file-system-uuid #f #:os-drv os-drv + #:register-closures? #t #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) -- cgit v1.2.3 From 903ae630a0ae0df9fabd5ebab7d44577d6e7d0fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Sun, 10 Sep 2017 21:40:46 +0200 Subject: install: Add 'passwd' to $PATH. Suggested by Jan Nieuwenhuizen. * gnu/system/install.scm (installation-os)[setuid-programs]: Add 'passwd'. --- gnu/system/install.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 7f6ffe9582..5c0aaed18a 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -337,9 +337,9 @@ Use Alt-F2 for documentation. (issue %issue) (services %installation-services) - ;; We don't need setuid programs so pass the empty list so we don't pull - ;; additional programs here. - (setuid-programs '()) + ;; We don't need setuid programs, except for 'passwd', which can be handy + ;; if one is to allow remote SSH login to the machine being installed. + (setuid-programs (list (file-append shadow "/bin/passwd"))) (pam-services ;; Explicitly allow for empty passwords. -- cgit v1.2.3 From 1e8d398abca66bbe85caad6d338ac80a104701d2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Sun, 10 Sep 2017 21:45:12 +0200 Subject: install: Add OpenSSH to the global profile. Suggested by Jan Nieuwenhuizen. * gnu/system/install.scm (installation-os)[packages]: Add OPENSSH. --- gnu/system/install.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 5c0aaed18a..4aecfaca2c 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -31,6 +31,7 @@ #:use-module (gnu packages bash) #:use-module (gnu packages bootloaders) #:use-module (gnu packages linux) + #:use-module (gnu packages ssh) #:use-module (gnu packages cryptsetup) #:use-module (gnu packages package-management) #:use-module (gnu packages disk) @@ -352,6 +353,7 @@ Use Alt-F2 for documentation. mdadm dosfstools ;mkfs.fat, for the UEFI boot partition btrfs-progs + openssh ;we already have sshd, having ssh/scp can help wireless-tools iw wpa-supplicant-minimal iproute ;; XXX: We used to have GNU fdisk here, but as of version ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable -- cgit v1.2.3 From 47cef4ecad54d112aa3b4bc509194d3d49a10785 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Tue, 5 Sep 2017 21:51:12 +0200 Subject: file-systems: Introduce (gnu system uuid). * gnu/build/file-systems.scm (sub-bytevector) (latin1->string, %fat32-endianness, fat32-uuid->string) (%iso9660-uuid-rx, string->iso9660-uuid) (iso9660-uuid->string, %network-byte-order) (dce-uuid->string, %uuid-rx, string->dce-uuid) (string->ext2-uuid, string->ext3-uuid, string->ext4-uuid) (vhashq, %uuid-parsers, %uuid-printers, string->uuid) (uuid->string): Move to... * gnu/system/uuid.scm: ... here. New file. * gnu/system/file-systems.scm (uuid): Move to the above file. * gnu/system/vm.scm: Adjust accordingly. * gnu/local.mk (GNU_SYSTEM_MODULES): Add uuid.scm. --- gnu/build/file-systems.scm | 167 +------------------------------- gnu/build/vm.scm | 2 +- gnu/local.mk | 1 + gnu/system/file-systems.scm | 22 +---- gnu/system/uuid.scm | 227 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 234 insertions(+), 185 deletions(-) create mode 100644 gnu/system/uuid.scm (limited to 'gnu/system') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index fbaf158951..32885f1d2e 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build file-systems) + #:use-module (gnu system uuid) #:use-module (guix build utils) #:use-module (guix build bournish) #:use-module (guix build syscalls) @@ -26,9 +27,6 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) - #:use-module (ice-9 format) - #:use-module (ice-9 regex) - #:use-module (ice-9 vlist) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) @@ -42,17 +40,6 @@ find-partition-by-luks-uuid canonicalize-device-spec - uuid->string - dce-uuid->string - string->uuid - string->dce-uuid - string->iso9660-uuid - string->ext2-uuid - string->ext3-uuid - string->ext4-uuid - string->btrfs-uuid - iso9660-uuid->string - bind-mount mount-flags->bit-mask @@ -98,20 +85,6 @@ takes a bytevector and returns #t when it's a valid superblock." (and (magic? block) block))))))))) -(define (sub-bytevector bv start size) - "Return a copy of the SIZE bytes of BV starting from offset START." - (let ((result (make-bytevector size))) - (bytevector-copy! bv start result 0 size) - result)) - -(define (latin1->string bv terminator) - "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate -that takes a number and returns #t when a termination character is found." - (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv)))) - (if (null? bytes) - #f - (list->string (map integer->char bytes))))) - (define null-terminated-latin1->string (cut latin1->string <> zero?)) @@ -199,10 +172,6 @@ if DEVICE does not contain a btrfs file system." ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>. -(define-syntax %fat32-endianness - ;; Endianness of fat file systems. - (identifier-syntax (endianness little))) - (define (fat32-superblock? sblock) "Return #t when SBLOCK is a fat32 superblock." (bytevector=? (sub-bytevector sblock 82 8) @@ -217,12 +186,6 @@ if DEVICE does not contain a btrfs file system." "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector." (sub-bytevector sblock 67 4)) -(define (fat32-uuid->string uuid) - "Convert fat32 UUID, a 4-byte bytevector, to its string representation." - (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2)) - (low (bytevector-uint-ref uuid 2 %fat32-endianness 2))) - (format #f "~:@(~x-~x~)" low high))) - (define (fat32-superblock-volume-name sblock) "Return the volume name of SBLOCK as a string of at most 11 characters, or #f if SBLOCK has no volume name. The volume name is a latin1 string. @@ -244,27 +207,6 @@ Trailing spaces are trimmed." ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. -(define %iso9660-uuid-rx - ;; Y m d H M S ss - (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$")) - -(define (string->iso9660-uuid str) - "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid). -Return its contents as a 16-byte bytevector. Return #f if STR is not a valid -ISO9660 UUID representation." - (and=> (regexp-exec %iso9660-uuid-rx str) - (lambda (match) - (letrec-syntax ((match-numerals - (syntax-rules () - ((_ index (name rest ...) body) - (let ((name (match:substring match index))) - (match-numerals (+ 1 index) (rest ...) body))) - ((_ index () body) - body)))) - (match-numerals 1 (year month day hour minute second hundredths) - (string->utf8 (string-append year month day - hour minute second hundredths))))))) - (define (iso9660-superblock? sblock) "Return #t when SBLOCK is an iso9660 volume descriptor." (bytevector=? (sub-bytevector sblock 1 6) @@ -311,20 +253,6 @@ SBLOCK as a bytevector. If that's not set, returns the creation time." modification-time))) (sub-bytevector time 0 16))) ; strips GMT offset. -(define (iso9660-uuid->string uuid) - "Given an UUID bytevector, return its timestamp string." - (define (digits->string bytes) - (latin1->string bytes (lambda (c) #f))) - (let* ((year (sub-bytevector uuid 0 4)) - (month (sub-bytevector uuid 4 2)) - (day (sub-bytevector uuid 6 2)) - (hour (sub-bytevector uuid 8 2)) - (minute (sub-bytevector uuid 10 2)) - (second (sub-bytevector uuid 12 2)) - (hundredths (sub-bytevector uuid 14 2)) - (parts (list year month day hour minute second hundredths))) - (string-append (string-join (map digits->string parts) "-")))) - (define (iso9660-superblock-volume-name sblock) "Return the volume name of SBLOCK as a string. The volume name is an ASCII string. Trailing spaces are trimmed." @@ -511,99 +439,6 @@ were found." (define find-partition-by-luks-uuid (find-partition luks-partition-uuid-predicate)) - -;;; -;;; UUIDs. -;;; - -(define-syntax %network-byte-order - (identifier-syntax (endianness big))) - -(define (dce-uuid->string uuid) - "Convert UUID, a 16-byte bytevector, to its string representation, something -like \"6b700d61-5550-48a1-874c-a3d86998990e\"." - ;; See <https://tools.ietf.org/html/rfc4122>. - (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) - (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) - (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) - (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) - (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) - (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" - time-low time-mid time-hi clock-seq node))) - -(define %uuid-rx - ;; The regexp of a UUID. - (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) - -(define (string->dce-uuid str) - "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and -return its contents as a 16-byte bytevector. Return #f if STR is not a valid -UUID representation." - (and=> (regexp-exec %uuid-rx str) - (lambda (match) - (letrec-syntax ((hex->number - (syntax-rules () - ((_ index) - (string->number (match:substring match index) - 16)))) - (put! - (syntax-rules () - ((_ bv index (number len) rest ...) - (begin - (bytevector-uint-set! bv index number - (endianness big) len) - (put! bv (+ index len) rest ...))) - ((_ bv index) - bv)))) - (let ((time-low (hex->number 1)) - (time-mid (hex->number 2)) - (time-hi (hex->number 3)) - (clock-seq (hex->number 4)) - (node (hex->number 5)) - (uuid (make-bytevector 16))) - (put! uuid 0 - (time-low 4) (time-mid 2) (time-hi 2) - (clock-seq 2) (node 6))))))) - -(define string->ext2-uuid string->dce-uuid) -(define string->ext3-uuid string->dce-uuid) -(define string->ext4-uuid string->dce-uuid) -(define string->btrfs-uuid string->dce-uuid) - -(define-syntax vhashq - (syntax-rules (=>) - ((_) - vlist-null) - ((_ (key others ... => value) rest ...) - (vhash-consq key value - (vhashq (others ... => value) rest ...))) - ((_ (=> value) rest ...) - (vhashq rest ...)))) - -(define %uuid-parsers - (vhashq - ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) - ('iso9660 => string->iso9660-uuid))) - -(define %uuid-printers - (vhashq - ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string) - ('iso9660 => iso9660-uuid->string) - ('fat32 'fat => fat32-uuid->string))) - -(define* (string->uuid str #:key (type 'dce)) - "Parse STR as a UUID of the given TYPE. On success, return the -corresponding bytevector; otherwise return #f." - (match (vhash-assq type %uuid-parsers) - (#f #f) - ((_ . (? procedure? parse)) (parse str)))) - -(define* (uuid->string bv #:key (type 'dce)) - "Convert BV, a bytevector, to the UUID string representation for TYPE." - (match (vhash-assq type %uuid-printers) - (#f #f) - ((_ . (? procedure? unparse)) (unparse bv)))) - (define* (canonicalize-device-spec spec #:optional (title 'any)) "Return the device name corresponding to SPEC. TITLE is a symbol, one of diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index ad67a3727f..6da4fa654e 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -26,7 +26,7 @@ #:use-module (guix build syscalls) #:use-module (gnu build linux-boot) #:use-module (gnu build install) - #:use-module (gnu build file-systems) + #:use-module (gnu system uuid) #:use-module (guix records) #:use-module ((guix combinators) #:select (fold2)) #:use-module (ice-9 format) diff --git a/gnu/local.mk b/gnu/local.mk index e98ee6d7fe..c1bc391101 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -468,6 +468,7 @@ GNU_SYSTEM_MODULES = \ %D%/system/nss.scm \ %D%/system/pam.scm \ %D%/system/shadow.scm \ + %D%/system/uuid.scm \ %D%/system/vm.scm \ \ %D%/build/activation.scm \ diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index bbac23fbdf..dd30559d7e 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -20,9 +20,10 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (guix records) - #:use-module ((gnu build file-systems) - #:select (string->uuid uuid->string)) - #:re-export (string->uuid + #:use-module ((gnu system uuid) + #:select (uuid string->uuid uuid->string)) + #:re-export (uuid ;backward compatibility + string->uuid uuid->string) #:export (<file-system> file-system @@ -44,7 +45,6 @@ file-system->spec spec->file-system specification->file-system-mapping - uuid %fuse-control-file-system %binary-format-file-system @@ -186,20 +186,6 @@ TARGET in the other system." (target spec) (writable? writable?))))) -(define-syntax uuid - (lambda (s) - "Return the bytevector corresponding to the given UUID representation." - (syntax-case s () - ((_ str) - (string? (syntax->datum #'str)) - ;; A literal string: do the conversion at expansion time. - (let ((bv (string->uuid (syntax->datum #'str)))) - (unless bv - (syntax-violation 'uuid "invalid UUID" s)) - (datum->syntax #'str bv))) - ((_ str) - #'(string->uuid str))))) - ;;; ;;; Common file systems. diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm new file mode 100644 index 0000000000..64dad5a374 --- /dev/null +++ b/gnu/system/uuid.scm @@ -0,0 +1,227 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.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 uuid) + #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:export (uuid + uuid->string + dce-uuid->string + string->uuid + string->dce-uuid + string->iso9660-uuid + string->ext2-uuid + string->ext3-uuid + string->ext4-uuid + string->btrfs-uuid + iso9660-uuid->string + + ;; XXX: For lack of a better place. + sub-bytevector + latin1->string)) + + +;;; +;;; Tools that lack a better place. +;;; + +(define (sub-bytevector bv start size) + "Return a copy of the SIZE bytes of BV starting from offset START." + (let ((result (make-bytevector size))) + (bytevector-copy! bv start result 0 size) + result)) + +(define (latin1->string bv terminator) + "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate +that takes a number and returns #t when a termination character is found." + (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv)))) + (if (null? bytes) + #f + (list->string (map integer->char bytes))))) + + +;;; +;;; DCE UUIDs. +;;; + +(define-syntax %network-byte-order + (identifier-syntax (endianness big))) + +(define (dce-uuid->string uuid) + "Convert UUID, a 16-byte bytevector, to its string representation, something +like \"6b700d61-5550-48a1-874c-a3d86998990e\"." + ;; See <https://tools.ietf.org/html/rfc4122>. + (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) + (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) + (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) + (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) + (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) + (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" + time-low time-mid time-hi clock-seq node))) + +(define %uuid-rx + ;; The regexp of a UUID. + (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) + +(define (string->dce-uuid str) + "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and +return its contents as a 16-byte bytevector. Return #f if STR is not a valid +UUID representation." + (and=> (regexp-exec %uuid-rx str) + (lambda (match) + (letrec-syntax ((hex->number + (syntax-rules () + ((_ index) + (string->number (match:substring match index) + 16)))) + (put! + (syntax-rules () + ((_ bv index (number len) rest ...) + (begin + (bytevector-uint-set! bv index number + (endianness big) len) + (put! bv (+ index len) rest ...))) + ((_ bv index) + bv)))) + (let ((time-low (hex->number 1)) + (time-mid (hex->number 2)) + (time-hi (hex->number 3)) + (clock-seq (hex->number 4)) + (node (hex->number 5)) + (uuid (make-bytevector 16))) + (put! uuid 0 + (time-low 4) (time-mid 2) (time-hi 2) + (clock-seq 2) (node 6))))))) + + +;;; +;;; ISO-9660. +;;; + +;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. + +(define %iso9660-uuid-rx + ;; Y m d H M S ss + (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$")) +(define (string->iso9660-uuid str) + "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid). +Return its contents as a 16-byte bytevector. Return #f if STR is not a valid +ISO9660 UUID representation." + (and=> (regexp-exec %iso9660-uuid-rx str) + (lambda (match) + (letrec-syntax ((match-numerals + (syntax-rules () + ((_ index (name rest ...) body) + (let ((name (match:substring match index))) + (match-numerals (+ 1 index) (rest ...) body))) + ((_ index () body) + body)))) + (match-numerals 1 (year month day hour minute second hundredths) + (string->utf8 (string-append year month day + hour minute second hundredths))))))) +(define (iso9660-uuid->string uuid) + "Given an UUID bytevector, return its timestamp string." + (define (digits->string bytes) + (latin1->string bytes (lambda (c) #f))) + (let* ((year (sub-bytevector uuid 0 4)) + (month (sub-bytevector uuid 4 2)) + (day (sub-bytevector uuid 6 2)) + (hour (sub-bytevector uuid 8 2)) + (minute (sub-bytevector uuid 10 2)) + (second (sub-bytevector uuid 12 2)) + (hundredths (sub-bytevector uuid 14 2)) + (parts (list year month day hour minute second hundredths))) + (string-append (string-join (map digits->string parts) "-")))) + + +;;; +;;; FAT32. +;;; + +(define-syntax %fat32-endianness + ;; Endianness of FAT file systems. + (identifier-syntax (endianness little))) + +(define (fat32-uuid->string uuid) + "Convert fat32 UUID, a 4-byte bytevector, to its string representation." + (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2)) + (low (bytevector-uint-ref uuid 2 %fat32-endianness 2))) + (format #f "~:@(~x-~x~)" low high))) + + +;;; +;;; Generic interface. +;;; + +(define string->ext2-uuid string->dce-uuid) +(define string->ext3-uuid string->dce-uuid) +(define string->ext4-uuid string->dce-uuid) +(define string->btrfs-uuid string->dce-uuid) + +(define-syntax vhashq + (syntax-rules (=>) + ((_) + vlist-null) + ((_ (key others ... => value) rest ...) + (vhash-consq key value + (vhashq (others ... => value) rest ...))) + ((_ (=> value) rest ...) + (vhashq rest ...)))) + +(define %uuid-parsers + (vhashq + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) + ('iso9660 => string->iso9660-uuid))) + +(define %uuid-printers + (vhashq + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string) + ('iso9660 => iso9660-uuid->string) + ('fat32 'fat => fat32-uuid->string))) + +(define* (string->uuid str #:key (type 'dce)) + "Parse STR as a UUID of the given TYPE. On success, return the +corresponding bytevector; otherwise return #f." + (match (vhash-assq type %uuid-parsers) + (#f #f) + ((_ . (? procedure? parse)) (parse str)))) + +(define* (uuid->string bv #:key (type 'dce)) + "Convert BV, a bytevector, to the UUID string representation for TYPE." + (match (vhash-assq type %uuid-printers) + (#f #f) + ((_ . (? procedure? unparse)) (unparse bv)))) + +(define-syntax uuid + (lambda (s) + "Return the bytevector corresponding to the given UUID representation." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + ;; A literal string: do the conversion at expansion time. + (let ((bv (string->uuid (syntax->datum #'str)))) + (unless bv + (syntax-violation 'uuid "invalid UUID" s)) + (datum->syntax #'str bv))) + ((_ str) + #'(string->uuid str))))) -- cgit v1.2.3 From 9b336338cdc0e46a3bf7a2913c2f61cd2410c4d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Wed, 6 Sep 2017 09:28:28 +0200 Subject: system: Introduce a disjoint UUID type. Conceptually a UUID is just a bytevector. However, there's software out there such as GRUB that relies on the string representation of different UUID types (e.g., the string representation of DCE UUIDs differs from that of ISO-9660 UUIDs, even if they are actually bytevectors of the same length). This new <uuid> record type allows us to preserve information about the type of UUID so we can eventually convert it to a string using the right representation. * gnu/system/uuid.scm (<uuid>): New record type. (bytevector->uuid): New procedure. (uuid): Return calls to 'make-uuid'. (uuid->string): Rewrite using 'match-lambda*' to accept a single 'uuid?' argument. * gnu/bootloader/grub.scm (grub-root-search): Check for 'uuid?' instead of 'bytevector?'. * gnu/system.scm (bootable-kernel-arguments): Check whether ROOT-DEVICE is 'uuid?'. (read-boot-parameters): Use 'bytevector->uuid' when the store device is a bytevector. (read-boot-parameters-file): Check for 'uuid?' instead of 'bytevector?'. (device->sexp): New procedure. (operating-system-boot-parameters-file): Use it for 'root-device' and 'store'. (operating-system-bootcfg): Remove conditional in definition of 'root-device'. * gnu/system/file-systems.scm (file-system->spec): Check for 'uuid?' on DEVICE and take its bytevector. * gnu/system/mapped-devices.scm (open-luks-device): Likewise. * gnu/system/vm.scm (iso9660-image): Call 'uuid-bytevector' for the #:volume-uuid argument. --- gnu/bootloader/grub.scm | 4 ++-- gnu/system.scm | 38 ++++++++++++++++++++++++---------- gnu/system/file-systems.scm | 8 +++++--- gnu/system/mapped-devices.scm | 7 +++++-- gnu/system/uuid.scm | 48 +++++++++++++++++++++++++++++++++++-------- gnu/system/vm.scm | 4 +++- 6 files changed, 82 insertions(+), 27 deletions(-) (limited to 'gnu/system') diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index a9f0875f36..96e53c5c2b 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -30,7 +30,7 @@ #:use-module (gnu artwork) #:use-module (gnu system) #:use-module (gnu bootloader) - #:use-module (gnu system file-systems) + #:use-module (gnu system uuid) #:autoload (gnu packages bootloaders) (grub) #:autoload (gnu packages compression) (gzip) #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) @@ -300,7 +300,7 @@ code." (match device ;; Preferably refer to DEVICE by its UUID or label. This is more ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>. - ((? bytevector? uuid) + ((? uuid? uuid) (format #f "search --fs-uuid --set ~a" (uuid->string device))) ((? string? label) diff --git a/gnu/system.scm b/gnu/system.scm index 6b35e3c0c7..a8d2a81316 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -54,6 +54,7 @@ #:use-module (gnu system locale) #:use-module (gnu system pam) #:use-module (gnu system linux-initrd) + #:use-module (gnu system uuid) #:use-module (gnu system file-systems) #:use-module (gnu system mapped-devices) #:use-module (ice-9 match) @@ -128,7 +129,14 @@ (define (bootable-kernel-arguments kernel-arguments system.drv root-device) "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be booted from ROOT-DEVICE" - (cons* (string-append "--root=" root-device) + (cons* (string-append "--root=" + (if (uuid? root-device) + + ;; Note: Always use the DCE format because that's + ;; what (gnu build linux-boot) expects for the + ;; '--root' kernel command-line option. + (uuid->string (uuid-bytevector root-device) 'dce) + root-device)) #~(string-append "--system=" #$system.drv) #~(string-append "--load=" #$system.drv "/boot") kernel-arguments)) @@ -261,6 +269,8 @@ directly by the user." (store-device (match (assq 'store rest) + (('store ('device (? bytevector? bv)) _ ...) + (bytevector->uuid bv)) (('store ('device device) _ ...) device) (_ ;the old format @@ -289,16 +299,12 @@ The object has its kernel-arguments extended in order to make it bootable." (let* ((file (string-append system "/parameters")) (params (call-with-input-file file read-boot-parameters)) (root (boot-parameters-root-device params)) - (root-device (if (bytevector? root) - (uuid->string root) - root)) (kernel-arguments (boot-parameters-kernel-arguments params))) (if params (boot-parameters (inherit params) (kernel-arguments (bootable-kernel-arguments kernel-arguments - system - root-device))) + system root))) #f))) (define (boot-parameters->menu-entry conf) @@ -875,9 +881,7 @@ listed in OS. The C library expects to find it under (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) - (root-device -> (if (eq? 'uuid (file-system-title root-fs)) - (uuid->string (file-system-device root-fs)) - (file-system-device root-fs))) + (root-device -> (file-system-device root-fs)) (params (operating-system-boot-parameters os system root-device)) (entry -> (boot-parameters->menu-entry params)) (bootloader-conf -> (operating-system-bootloader os))) @@ -917,6 +921,15 @@ kernel arguments for that derivation to <boot-parameters>." (store-device (fs->boot-device store)) (store-mount-point (file-system-mount-point store)))))) +(define (device->sexp device) + "Serialize DEVICE as an sexp (really, as an object with a read syntax.)" + (match device + ((? uuid? uuid) + ;; TODO: Preserve the type of UUID. + (uuid-bytevector uuid)) + (_ + device))) + (define* (operating-system-boot-parameters-file os #:optional (system.drv #f)) "Return a file that describes the boot parameters of OS. The primary use of this file is the reconstruction of GRUB menu entries for old configurations. @@ -934,14 +947,17 @@ being stored into the \"parameters\" file)." #~(boot-parameters (version 0) (label #$(boot-parameters-label params)) - (root-device #$(boot-parameters-root-device params)) + (root-device + #$(device->sexp + (boot-parameters-root-device params))) (kernel #$(boot-parameters-kernel params)) (kernel-arguments #$(boot-parameters-kernel-arguments params)) (initrd #$(boot-parameters-initrd params)) (bootloader-name #$(boot-parameters-bootloader-name params)) (store - (device #$(boot-parameters-store-device params)) + (device + #$(device->sexp (boot-parameters-store-device params))) (mount-point #$(boot-parameters-store-mount-point params)))) #:set-load-path? #f))) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index dd30559d7e..52f16676f5 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -20,8 +20,7 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (guix records) - #:use-module ((gnu system uuid) - #:select (uuid string->uuid uuid->string)) + #:use-module (gnu system uuid) #:re-export (uuid ;backward compatibility string->uuid uuid->string) @@ -157,7 +156,10 @@ store--e.g., if FS is the root file system." initrd code." (match fs (($ <file-system> device title mount-point type flags options _ _ check?) - (list device title mount-point type flags options check?)))) + (list (if (uuid? device) + (uuid-bytevector device) + device) + title mount-point type flags options check?)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding <file-system> object." diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 18b9f5b4b6..17cf6b7163 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2017 Mark H Weaver <mhw@netris.org> ;;; @@ -24,6 +24,7 @@ #:use-module (guix modules) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module (gnu system uuid) #:autoload (gnu packages cryptsetup) (cryptsetup-static) #:autoload (gnu packages linux) (mdadm-static) #:use-module (srfi srfi-1) @@ -99,7 +100,9 @@ 'cryptsetup'." (with-imported-modules (source-module-closure '((gnu build file-systems))) - #~(let ((source #$source)) + #~(let ((source #$(if (uuid? source) + (uuid-bytevector source) + source))) ;; XXX: 'use-modules' should be at the top level. (use-modules (rnrs bytevectors) ;bytevector? ((gnu build file-systems) diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index 64dad5a374..60626ebb12 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -19,12 +19,19 @@ (define-module (gnu system uuid) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 regex) #:use-module (ice-9 format) #:export (uuid + uuid? + uuid-type + uuid-bytevector + + bytevector->uuid + uuid->string dce-uuid->string string->uuid @@ -206,15 +213,27 @@ corresponding bytevector; otherwise return #f." (#f #f) ((_ . (? procedure? parse)) (parse str)))) -(define* (uuid->string bv #:key (type 'dce)) - "Convert BV, a bytevector, to the UUID string representation for TYPE." - (match (vhash-assq type %uuid-printers) - (#f #f) - ((_ . (? procedure? unparse)) (unparse bv)))) +;; High-level UUID representation that carries its type with it. +;; +;; This is necessary to serialize bytevectors with the right printer in some +;; circumstances. For instance, GRUB "search --fs-uuid" command compares the +;; string representation of UUIDs, not the raw bytes; thus, when emitting a +;; GRUB 'search' command, we need to procedure the right string representation +;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>). +(define-record-type <uuid> + (make-uuid type bv) + uuid? + (type uuid-type) ;'dce | 'iso9660 | ... + (bv uuid-bytevector)) + +(define* (bytevector->uuid bv #:optional (type 'dce)) + "Return a UUID object make of BV and TYPE." + (make-uuid type bv)) (define-syntax uuid (lambda (s) - "Return the bytevector corresponding to the given UUID representation." + "Return the UUID object corresponding to the given UUID representation." + ;; TODO: Extend to types other than DCE. (syntax-case s () ((_ str) (string? (syntax->datum #'str)) @@ -222,6 +241,19 @@ corresponding bytevector; otherwise return #f." (let ((bv (string->uuid (syntax->datum #'str)))) (unless bv (syntax-violation 'uuid "invalid UUID" s)) - (datum->syntax #'str bv))) + #`(make-uuid 'dce #,(datum->syntax #'str bv)))) ((_ str) - #'(string->uuid str))))) + #'(make-uuid 'dce (string->uuid str)))))) + +(define uuid->string + ;; Convert the given bytevector or UUID object, to the corresponding UUID + ;; string representation. + (match-lambda* + (((? bytevector? bv)) + (uuid->string bv 'dce)) + (((? bytevector? bv) type) + (match (vhash-assq type %uuid-printers) + (#f #f) + ((_ . (? procedure? unparse)) (unparse bv)))) + (((? uuid? uuid)) + (uuid->string (uuid-bytevector uuid) (uuid-type uuid))))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b106dff0a8..92f0444ed8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -57,6 +57,7 @@ #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) + #:use-module (gnu system uuid) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -231,7 +232,8 @@ INPUTS is a list of inputs (as for packages)." #:register-closures? #$register-closures? #:closures graphs #:volume-id #$file-system-label - #:volume-uuid #$file-system-uuid) + #:volume-uuid #$(and=> file-system-uuid + uuid-bytevector)) (reboot)))) #:system system #:make-disk-image? #f -- cgit v1.2.3 From ce094b4663da6aa52d02f398a19e1d2892641b7d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Wed, 6 Sep 2017 10:35:01 +0200 Subject: uuid: 'uuid' macro supports more UUID types. * gnu/system/uuid.scm (string->uuid): Turn 'type' into an optional argument. (uuid): Add clauses to allow for an optional 'type' parameter. --- gnu/system/uuid.scm | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index 60626ebb12..1dd6a11339 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -206,7 +206,7 @@ ISO9660 UUID representation." ('iso9660 => iso9660-uuid->string) ('fat32 'fat => fat32-uuid->string))) -(define* (string->uuid str #:key (type 'dce)) +(define* (string->uuid str #:optional (type 'dce)) "Parse STR as a UUID of the given TYPE. On success, return the corresponding bytevector; otherwise return #f." (match (vhash-assq type %uuid-parsers) @@ -233,17 +233,23 @@ corresponding bytevector; otherwise return #f." (define-syntax uuid (lambda (s) "Return the UUID object corresponding to the given UUID representation." - ;; TODO: Extend to types other than DCE. - (syntax-case s () - ((_ str) - (string? (syntax->datum #'str)) + (syntax-case s (quote) + ((_ str (quote type)) + (and (string? (syntax->datum #'str)) + (identifier? #'type)) ;; A literal string: do the conversion at expansion time. - (let ((bv (string->uuid (syntax->datum #'str)))) + (let ((bv (string->uuid (syntax->datum #'str) + (syntax->datum #'type)))) (unless bv (syntax-violation 'uuid "invalid UUID" s)) - #`(make-uuid 'dce #,(datum->syntax #'str bv)))) + #`(make-uuid 'type #,(datum->syntax s bv)))) + ((_ str) + (string? (syntax->datum #'str)) + #'(uuid str 'dce)) ((_ str) - #'(make-uuid 'dce (string->uuid str)))))) + #'(make-uuid 'dce (string->uuid str 'dce))) + ((_ str type) + #'(make-uuid type (string->uuid str type)))))) (define uuid->string ;; Convert the given bytevector or UUID object, to the corresponding UUID -- cgit v1.2.3 From fd3b4b985d5bbd5d91362aa91079c1155018fa34 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Wed, 6 Sep 2017 23:12:32 +0200 Subject: vm: Allow users to specify a UUID for the root partition. * gnu/system/vm.scm (qemu-image): Add #:file-system-uuid parameter; pass it as the 'uuid' field of the root partition. --- gnu/system/vm.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 92f0444ed8..9e900182ae 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -248,6 +248,7 @@ INPUTS is a list of inputs (as for packages)." (disk-image-format "qcow2") (file-system-type "ext4") file-system-label + file-system-uuid os-drv bootcfg-drv bootloader @@ -257,7 +258,10 @@ INPUTS is a list of inputs (as for packages)." "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root -partition. The returned image is a full disk image that runs OS-DERIVATION, +partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root +partition (a UUID object). + +The returned image is a full disk image that runs OS-DERIVATION, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) @@ -307,6 +311,8 @@ the image." (partitions (list (partition (size root-size) (label #$file-system-label) + (uuid #$(and=> file-system-uuid + uuid-bytevector)) (file-system #$file-system-type) (flags '(boot)) (initializer initialize)) -- cgit v1.2.3 From 5f7fe1c57ecb9525aa7e13e38af2aab022bae078 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Wed, 6 Sep 2017 23:16:09 +0200 Subject: vm: Generate a UUID to identify the root file system. This makes collisions less likely than when using a label to look up the partition. See <https://bugs.gnu.org/27735>. * gnu/system/vm.scm (operating-system-uuid): New procedure. (system-disk-image): Define 'root-uuid' and use it for the root file system. Pass it to 'iso9660-image' and 'qemu-image'. --- gnu/system/vm.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 45 insertions(+), 6 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 9e900182ae..78143e4f7a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -61,6 +61,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (expression->derivation-in-linux-vm @@ -350,6 +351,35 @@ the image." ;;; VM and disk images. ;;; +(define* (operating-system-uuid os #:optional (type 'dce)) + "Compute UUID object with a deterministic \"UUID\" for OS, of the given +TYPE (one of 'iso9660 or 'dce). Return a UUID object." + (if (eq? type 'iso9660) + (let ((pad (compose (cut string-pad <> 2 #\0) + number->string)) + (h (hash (operating-system-services os) 3600))) + (bytevector->uuid + (string->iso9660-uuid + (string-append "1970-01-01-" + (pad (hash (operating-system-host-name os) 24)) "-" + (pad (quotient h 60)) "-" + (pad (modulo h 60)) "-" + (pad (hash (operating-system-file-systems os) 100)))) + 'iso9660)) + (bytevector->uuid + (uint-list->bytevector + (list (hash file-system-type + (expt 2 32)) + (hash (operating-system-host-name os) + (expt 2 32)) + (hash (operating-system-services os) + (expt 2 32)) + (hash (operating-system-file-systems os) + (expt 2 32))) + (endianness little) + 4) + type))) + (define* (system-disk-image os #:key (name "disk-image") @@ -366,12 +396,20 @@ to USB sticks meant to be read-only." (if (string=? "iso9660" file-system-type) string-upcase identity)) + (define root-label - ;; Volume name of the root file system. Since we don't know which device - ;; will hold it, we use the volume name to find it (using the UUID would - ;; be even better, but somewhat less convenient.) + ;; Volume name of the root file system. (normalize-label "GuixSD_image")) + (define root-uuid + ;; UUID of the root file system, computed in a deterministic fashion. + ;; This is what we use to locate the root file system so it has to be + ;; different from the user's own file system UUIDs. + (operating-system-uuid os + (if (string=? file-system-type "iso9660") + 'iso9660 + 'dce))) + (define file-systems-to-keep (remove (lambda (fs) (string=? (file-system-mount-point fs) "/")) @@ -395,8 +433,8 @@ to USB sticks meant to be read-only." ;; Force our own root file system. (file-systems (cons (file-system (mount-point "/") - (device root-label) - (title 'label) + (device root-uuid) + (title 'uuid) (type file-system-type)) file-systems-to-keep))))) @@ -405,7 +443,7 @@ to USB sticks meant to be read-only." (if (string=? "iso9660" file-system-type) (iso9660-image #:name name #:file-system-label root-label - #:file-system-uuid #f + #:file-system-uuid root-uuid #:os-drv os-drv #:register-closures? #t #:bootcfg-drv bootcfg @@ -422,6 +460,7 @@ to USB sticks meant to be read-only." #:disk-image-format "raw" #:file-system-type file-system-type #:file-system-label root-label + #:file-system-uuid root-uuid #:copy-inputs? #t #:register-closures? #t #:inputs `(("system" ,os-drv) -- cgit v1.2.3 From 4e854b1814a9216ae7cc90aef4d82fd989a519c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Tue, 12 Sep 2017 22:28:43 +0200 Subject: install: Include the whole bare-bones OS in the image. * gnu/system/install.scm (%installation-services): Load "example/bare-bones.tmpl". Add a 'gc-root-service-type' instance. --- gnu/system/install.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 4aecfaca2c..eb362f91a8 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -215,6 +215,9 @@ You have been warned. Thanks for being so brave. (auto-login "root") (login-pause? #t)))) + (define bare-bones-os + (load "examples/bare-bones.tmpl")) + (list (mingetty-service (mingetty-configuration (tty "tty1") (auto-login "root"))) @@ -284,7 +287,11 @@ You have been warned. Thanks for being so brave. ;; connections to this system to work. (service special-files-service-type `(("/bin/sh" ,(file-append (canonical-package bash) - "/bin/sh"))))))) + "/bin/sh")))) + + ;; Keep a reference to BARE-BONES-OS to make sure it can be + ;; installed without downloading/building anything. + (service gc-root-service-type (list bare-bones-os))))) (define %issue ;; Greeting. -- cgit v1.2.3 From 960c40de21650368021b20c78b79101bce022b51 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Tue, 12 Sep 2017 22:35:12 +0200 Subject: doc: Use Screen and OpenSSH in the bare-bones example. * gnu/system/examples/bare-bones.tmpl (packages): Remove TCPDUMP; add SCREEN and OPENSSH. * doc/guix.texi (Using the Configuration System): Adjust explanation accordingly. --- doc/guix.texi | 5 +++-- gnu/system/examples/bare-bones.tmpl | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index c5b277d027..0633691228 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8186,8 +8186,9 @@ environment variable---in addition to the per-user profiles provides all the tools one would expect for basic user and administrator tasks---including the GNU Core Utilities, the GNU Networking Utilities, the GNU Zile lightweight text editor, @command{find}, @command{grep}, -etc. The example above adds tcpdump to those, taken from the @code{(gnu -packages admin)} module (@pxref{Package Modules}). The +etc. The example above adds GNU@tie{}Screen and OpenSSH to those, +taken from the @code{(gnu packages screen)} and @code{(gnu packages ssh)} +modules (@pxref{Package Modules}). The @code{(list package output)} syntax can be used to add a specific output of a package: diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index 459d241885..7e0c8fbee0 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -3,7 +3,7 @@ (use-modules (gnu)) (use-service-modules networking ssh) -(use-package-modules admin) +(use-package-modules screen ssh) (operating-system (host-name "komputilo") @@ -40,7 +40,7 @@ %base-user-accounts)) ;; Globally-installed packages. - (packages (cons tcpdump %base-packages)) + (packages (cons* screen openssh %base-packages)) ;; Add services to the baseline: a DHCP client and ;; an SSH server. -- cgit v1.2.3 From fbc31dc1247d3a494246e69f3cf28476af9eb9d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Thu, 21 Sep 2017 23:52:45 +0200 Subject: services: Move 'session-environment-service-type' to pam.scm. * gnu/services/base.scm (environment-variables->environment-file) (session-environment-service-type) (session-environment-service): Move to... * gnu/system/pam.scm: ... here. --- gnu/services/base.scm | 43 ------------------------------------------- gnu/system/pam.scm | 47 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 46 insertions(+), 44 deletions(-) (limited to 'gnu/system') diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 10c8f1b6a3..64620a9b0a 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -59,8 +59,6 @@ user-unmount-service swap-service user-processes-service - session-environment-service - session-environment-service-type host-name-service console-keymap-service %default-console-font @@ -600,47 +598,6 @@ to add @var{device} to the kernel's entropy pool. The service will fail if (rng-tools rng-tools) (device device)))) - -;;; -;;; System-wide environment variables. -;;; - -(define (environment-variables->environment-file vars) - "Return a file for pam_env(8) that contains environment variables VARS." - (apply mixed-text-file "environment" - (append-map (match-lambda - ((key . value) - (list key "=" value "\n"))) - vars))) - -(define session-environment-service-type - (service-type - (name 'session-environment) - (extensions - (list (service-extension - etc-service-type - (lambda (vars) - (list `("environment" - ,(environment-variables->environment-file vars))))))) - (compose concatenate) - (extend append) - (description - "Populate @file{/etc/environment} with the specified environment -variables. The value of this service is a list of name/value pairs for -environments variables, such as: - -@example -'((\"TZ\" . \"Canada/Pacific\")) -@end example\n"))) - -(define (session-environment-service vars) - "Return a service that builds the @file{/etc/environment}, which can be read -by PAM-aware applications to set environment variables for sessions. - -VARS should be an association list in which both the keys and the values are -strings or string-valued gexps." - (service session-environment-service-type vars)) - ;;; ;;; Console & co. diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm index eedf933946..13f76a50ed 100644 --- a/gnu/system/pam.scm +++ b/gnu/system/pam.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,6 +50,9 @@ unix-pam-service base-pam-services + session-environment-service + session-environment-service-type + pam-root-service-type pam-root-service)) @@ -276,6 +279,48 @@ authenticate to run COMMAND." '("useradd" "userdel" "usermod" "groupadd" "groupdel" "groupmod")))) + +;;; +;;; System-wide environment variables. +;;; + +(define (environment-variables->environment-file vars) + "Return a file for pam_env(8) that contains environment variables VARS." + (apply mixed-text-file "environment" + (append-map (match-lambda + ((key . value) + (list key "=" value "\n"))) + vars))) + +(define session-environment-service-type + (service-type + (name 'session-environment) + (extensions + (list (service-extension + etc-service-type + (lambda (vars) + (list `("environment" + ,(environment-variables->environment-file vars))))))) + (compose concatenate) + (extend append) + (description + "Populate @file{/etc/environment}, which is honored by @code{pam_env}, +with the specified environment variables. The value of this service is a list +of name/value pairs for environments variables, such as: + +@example +'((\"TZ\" . \"Canada/Pacific\")) +@end example\n"))) + +(define (session-environment-service vars) + "Return a service that builds the @file{/etc/environment}, which can be read +by PAM-aware applications to set environment variables for sessions. + +VARS should be an association list in which both the keys and the values are +strings or string-valued gexps." + (service session-environment-service-type vars)) + + ;;; ;;; PAM root service. -- cgit v1.2.3 From 8a7d81a5e23c4d59fbabf2550db32d4ba5572e4b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès <ludo@gnu.org> Date: Fri, 22 Sep 2017 18:25:21 +0200 Subject: uuid: Add a parser for FAT32 UUIDs. * gnu/system/uuid.scm (%fat32-uuid-rx): New variable. (string->fat32-uuid): New procedure. (%uuid-parsers): Add it. * tests/uuid.scm ("uuid, FAT32, format preserved"): New test. --- gnu/system/uuid.scm | 18 ++++++++++++++++++ tests/uuid.scm | 4 ++++ 2 files changed, 22 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index 1dd6a11339..6470abb8cc 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -41,6 +41,7 @@ string->ext3-uuid string->ext4-uuid string->btrfs-uuid + string->fat32-uuid iso9660-uuid->string ;; XXX: For lack of a better place. @@ -175,6 +176,22 @@ ISO9660 UUID representation." (low (bytevector-uint-ref uuid 2 %fat32-endianness 2))) (format #f "~:@(~x-~x~)" low high))) +(define %fat32-uuid-rx + (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$")) + +(define (string->fat32-uuid str) + "Parse STR, which is in FAT32 format, and return a bytevector or #f." + (match (regexp-exec %fat32-uuid-rx str) + (#f + #f) + (rx-match + (uint-list->bytevector (list (string->number + (match:substring rx-match 2) 16) + (string->number + (match:substring rx-match 1) 16)) + %fat32-endianness + 2)))) + ;;; ;;; Generic interface. @@ -198,6 +215,7 @@ ISO9660 UUID representation." (define %uuid-parsers (vhashq ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) + ('fat32 'fat => string->fat32-uuid) ('iso9660 => string->iso9660-uuid))) (define %uuid-printers diff --git a/tests/uuid.scm b/tests/uuid.scm index c2f15de996..aacce77233 100644 --- a/tests/uuid.scm +++ b/tests/uuid.scm @@ -53,4 +53,8 @@ "1970-01-01-17-14-42-99" (uuid->string (uuid "1970-01-01-17-14-42-99" 'iso9660))) +(test-equal "uuid, FAT32, format preserved" + "1234-ABCD" + (uuid->string (uuid "1234-abcd" 'fat32))) + (test-end) -- cgit v1.2.3