From 4138e782dcfea675ebc2347cbd4ea9abeb9dff36 Mon Sep 17 00:00:00 2001 From: Christopher Baines 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 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 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 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 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 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 . (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." ;; . -(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." ;; . -(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 . - (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 ) 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 @@ -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 +;;; Copyright © 2017 Danny Milosavljevic +;;; +;;; 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 . + +(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 . + (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 ) 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. +;;; + +;; . + +(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 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 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 (): 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 . - ((? 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 ." (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 (($ 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 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 +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Andreas Enge ;;; Copyright © 2017 Mark H Weaver ;;; @@ -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 ). +(define-record-type + (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 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 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 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 . * 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 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 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 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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; 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 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