From d2bcf35e1805b06fb575352531d9c439425dc379 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Nov 2016 22:56:41 +0100 Subject: vm: Avoid needless file copy in 'load-in-linux-vm'. Reported by Chris Webber. * gnu/build/vm.scm (load-in-linux-vm)[image-file]: Remove. Directly refer to OUTPUT instead. --- gnu/build/vm.scm | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index cc5cf45362..60ee18ebe0 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -79,12 +79,9 @@ it via /dev/hda. REFERENCES-GRAPHS can specify a list of reference-graph files as produced by the #:references-graphs parameter of 'derivation'." - (define image-file - (string-append "image." disk-image-format)) - (when make-disk-image? (unless (zero? (system* "qemu-img" "create" "-f" disk-image-format - image-file + output (number->string disk-image-size))) (error "qemu-img failed"))) @@ -115,7 +112,7 @@ the #:references-graphs parameter of 'derivation'." builder) (append (if make-disk-image? - `("-drive" ,(string-append "file=" image-file + `("-drive" ,(string-append "file=" output ",if=virtio")) '()) ;; Only enable kvm if we see /dev/kvm exists. @@ -126,11 +123,10 @@ the #:references-graphs parameter of 'derivation'." '())))) (error "qemu failed" qemu)) - (if make-disk-image? - (copy-file image-file output) - (begin - (mkdir output) - (copy-recursively "xchg" output)))) + ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already. + (unless make-disk-image? + (mkdir output) + (copy-recursively "xchg" output))) ;;; -- cgit v1.2.3 From 0c85db79f7a8abc3bcdbf8931d959fe94306a5a1 Mon Sep 17 00:00:00 2001 From: John Darrington Date: Sat, 26 Nov 2016 10:29:23 +0100 Subject: gnu: Allow nfs file systems to be automatically mounted. * gnu/build/file-systems.scm (mount-file-system): Append target addr= when mounting nfs filesystems. --- gnu/build/file-systems.scm | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 0d55e91978..431b287d0c 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -464,6 +464,27 @@ form: DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to run a file system check." + + (define (mount-nfs source mount-point type flags options) + (let* ((idx (string-rindex source #\:)) + (host-part (string-take source idx)) + ;; Strip [] from around host if present + (host (match (string-split host-part (string->char-set "[]")) + (("" h "") h) + ((h) h))) + (aa (match (getaddrinfo host "nfs") ((x . _) x))) + (sa (addrinfo:addr aa)) + (inet-addr (inet-ntop (sockaddr:fam sa) + (sockaddr:addr sa)))) + + ;; Mounting an NFS file system requires passing the address + ;; of the server in the addr= option + (mount source mount-point type flags + (string-append "addr=" + inet-addr + (if options + (string-append "," options) + ""))))) (match spec ((source title mount-point type (flags ...) options check?) (let ((source (canonicalize-device-spec source title)) @@ -481,7 +502,11 @@ run a file system check." (call-with-output-file mount-point (const #t))) (mkdir-p mount-point)) - (mount source mount-point type flags options) + (cond + ((string-prefix? "nfs" type) + (mount-nfs source mount-point type flags options)) + (else + (mount source mount-point type flags options))) ;; For read-only bind mounts, an extra remount is needed, as per ;; , which still applies to Linux 4.0. -- cgit v1.2.3 From 3593e5d5c50b08cf69739aac98cd7c89247fa6da Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Dec 2016 21:49:25 +0100 Subject: gnu: cross-base: Move phases to (gnu build cross-toolchain). * gnu/packages/cross-base.scm (cross-gcc-arguments) <#:phases>: Use 'cross-gcc-build-phases', and move body cross-toolchain.scm. (cross-gcc): Add #:imported-modules. Add (gnu build cross-toolchain) to #:modules. * gnu/build/cross-toolchain.scm: New file, with code from 'cross-gcc-arguments'. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- gnu/build/cross-toolchain.scm | 178 ++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + gnu/packages/cross-base.scm | 140 ++------------------------------- 3 files changed, 185 insertions(+), 134 deletions(-) create mode 100644 gnu/build/cross-toolchain.scm (limited to 'gnu/build') diff --git a/gnu/build/cross-toolchain.scm b/gnu/build/cross-toolchain.scm new file mode 100644 index 0000000000..450443ca63 --- /dev/null +++ b/gnu/build/cross-toolchain.scm @@ -0,0 +1,178 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015 Mark H Weaver +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2016 Manolis Fragkiskos Ragkousis +;;; +;;; 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 build cross-toolchain) + #:use-module (guix build utils) + #:use-module (guix build gnu-build-system) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:export (cross-gcc-build-phases)) + +;;; Commentary: +;;; +;;; This module provides tools to build a cross-compiler. +;;; +;;; Code: + +(define %gcc-include-paths + ;; Environment variables for header search paths. + ;; Note: See for why not 'CPATH'. + '("C_INCLUDE_PATH" + "CPLUS_INCLUDE_PATH" + "OBJC_INCLUDE_PATH" + "OBJCPLUS_INCLUDE_PATH")) + +(define %gcc-cross-include-paths + ;; Search path for target headers when cross-compiling. + (map (cut string-append "CROSS_" <>) %gcc-include-paths)) + +(define* (make-cross-binutils-visible #:key outputs inputs target + #:allow-other-keys) + "Create symlinks for 'as', 'nm', and 'ld' in the \"out\" output, under +libexec/gcc, so that the cross-GCC can find them." + (let* ((out (assoc-ref outputs "out")) + (libexec (string-append out "/libexec/gcc/" target)) + (binutils (string-append (assoc-ref inputs "binutils-cross") + "/bin/" target "-")) + (wrapper (string-append (assoc-ref inputs "ld-wrapper-cross") + "/bin/" target "-ld"))) + (for-each (lambda (file) + (symlink (string-append binutils file) + (string-append libexec "/" file))) + '("as" "nm")) + (symlink wrapper (string-append libexec "/ld")) + #t)) + +(define* (set-cross-path #:key inputs #:allow-other-keys) + "Add the cross kernel headers to CROSS_CPATH, and remove them from +C_INCLUDE_PATH et al." + (match (assoc-ref inputs "libc") + ((? string? libc) + (let ((kernel (assoc-ref inputs "xkernel-headers"))) + (define (cross? x) + ;; Return #t if X is a cross-libc or cross Linux. + (or (string-prefix? libc x) + (string-prefix? kernel x))) + + (let ((cpath (string-append libc "/include" + ":" kernel "/include"))) + (for-each (cut setenv <> cpath) + %gcc-cross-include-paths)) + + (setenv "CROSS_LIBRARY_PATH" + (string-append libc "/lib:" kernel "/lib")) ;for Hurd's libihash + + (for-each (lambda (var) + (and=> (getenv var) + (lambda (value) + (let* ((path (search-path-as-string->list value)) + (native-path (list->search-path-as-string + (remove cross? path) ":"))) + (setenv var native-path))))) + (cons "LIBRARY_PATH" %gcc-include-paths)) + #t)) + (#f + ;; We're building the sans-libc cross-compiler, so nothing to do. + #t))) + +(define* (set-cross-path/mingw #:key inputs #:allow-other-keys) + "Add the cross MinGW headers to CROSS_C_*_INCLUDE_PATH, and remove them from +C_*INCLUDE_PATH." + (let ((libc (assoc-ref inputs "libc")) + (gcc (assoc-ref inputs "gcc"))) + (define (cross? x) + (and libc (string-prefix? libc x))) + + (define (unpacked-mingw-dir) + (match (scandir "." (lambda (name) + (string-contains name "mingw-w64"))) + ((mingw-dir) + (string-append + (getcwd) "/" mingw-dir "/mingw-w64-headers")))) + + (if libc + (let ((cpath (string-append libc "/include" + ":" libc "/i686-w64-mingw32/include"))) + (for-each (cut setenv <> cpath) + %gcc-cross-include-paths)) + + ;; libc is false, so we are building xgcc-sans-libc. + ;; Add essential headers from mingw-w64. + (let ((mingw-source (assoc-ref inputs "mingw-source"))) + (system* "tar" "xvf" mingw-source) + (let ((mingw-headers (unpacked-mingw-dir))) + ;; We need _mingw.h which will gets built from _mingw.h.in by + ;; mingw-w64's configure. We cannot configure mingw-w64 until we + ;; have xgcc-sans-libc; substitute to the rescue. + (copy-file (string-append mingw-headers "/crt/_mingw.h.in") + (string-append mingw-headers "/crt/_mingw.h")) + + (substitute* (string-append mingw-headers "/crt/_mingw.h") + (("@MINGW_HAS_SECURE_API@") + "#define MINGW_HAS_SECURE_API 1")) + + (let ((cpath (string-append mingw-headers "/include" + ":" mingw-headers "/crt" + ":" mingw-headers + "/defaults/include"))) + (for-each (cut setenv <> cpath) + (cons "CROSS_LIBRARY_PATH" + %gcc-cross-include-paths)))))) + + (when libc + (setenv "CROSS_LIBRARY_PATH" + (string-append libc "/lib" + ":" libc "/i686-w64-mingw32/lib"))) + + (setenv "CPP" (string-append gcc "/bin/cpp")) + (for-each (lambda (var) + (and=> (getenv var) + (lambda (value) + (let* ((path (search-path-as-string->list + value)) + (native-path (list->search-path-as-string + (remove cross? path) ":"))) + (setenv var native-path))))) + (cons "LIBRARY_PATH" %gcc-include-paths)) + #t)) + +(define (install-strip . _) + "Install a stripped GCC." + ;; Unlike our 'strip' phase, this will do the right thing for + ;; cross-compilers. + (zero? (system* "make" "install-strip"))) + +(define* (cross-gcc-build-phases target + #:optional (phases %standard-phases)) + "Modify PHASES to include everything needed to build a cross-GCC for TARGET, +a target triplet." + (modify-phases phases + (add-before 'configure 'set-cross-path + (if (string-contains target "mingw") + set-cross-path/mingw + set-cross-path)) + (add-after 'install 'make-cross-binutils-visible + (cut make-cross-binutils-visible #:target target <...>)) + (replace 'install install-strip))) + +;;; cross-toolchain.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index 1f98513ca3..eec0e018b5 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -436,6 +436,7 @@ GNU_SYSTEM_MODULES = \ %D%/system/vm.scm \ \ %D%/build/activation.scm \ + %D%/build/cross-toolchain.scm \ %D%/build/file-systems.scm \ %D%/build/install.scm \ %D%/build/linux-boot.scm \ diff --git a/gnu/packages/cross-base.scm b/gnu/packages/cross-base.scm index 7917e9fd0a..763bbf50e2 100644 --- a/gnu/packages/cross-base.scm +++ b/gnu/packages/cross-base.scm @@ -164,136 +164,7 @@ may be either a libc package or #f.)" ,flags)) flags)) ((#:phases phases) - (let ((phases - `(alist-cons-after - 'install 'make-cross-binutils-visible - (lambda* (#:key outputs inputs #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (libexec (string-append out "/libexec/gcc/" - ,target)) - (binutils (string-append - (assoc-ref inputs "binutils-cross") - "/bin/" ,target "-")) - (wrapper (string-append - (assoc-ref inputs "ld-wrapper-cross") - "/bin/" ,target "-ld"))) - (for-each (lambda (file) - (symlink (string-append binutils file) - (string-append libexec "/" - file))) - '("as" "nm")) - (symlink wrapper (string-append libexec "/ld")) - #t)) - (alist-replace - 'install - (lambda _ - ;; Unlike our 'strip' phase, this will do the right thing - ;; for cross-compilers. - (zero? (system* "make" "install-strip"))) - ,phases)))) - (cond - ((target-mingw? target) - `(modify-phases ,phases - (add-before - 'configure 'set-cross-path - (lambda* (#:key inputs #:allow-other-keys) - ;; Add the cross mingw headers to CROSS_C_*_INCLUDE_PATH, - ;; and remove them from C_*INCLUDE_PATH. - (let ((libc (assoc-ref inputs "libc")) - (gcc (assoc-ref inputs "gcc"))) - (define (cross? x) - (and libc (string-prefix? libc x))) - (define (unpacked-mingw-dir) - (match - (scandir - "." - (lambda (name) (string-contains name "mingw-w64"))) - ((mingw-dir) - (string-append - (getcwd) "/" mingw-dir "/mingw-w64-headers")))) - (if libc - (let ((cpath (string-append - libc "/include" - ":" libc "/i686-w64-mingw32/include"))) - (for-each (cut setenv <> cpath) - ',%gcc-cross-include-paths)) - ;; libc is false, so we are building xgcc-sans-libc - ;; Add essential headers from mingw-w64. - (let ((mingw-source (assoc-ref inputs "mingw-source"))) - (system* "tar" "xf" mingw-source) - (let ((mingw-headers (unpacked-mingw-dir))) - ;; We need _mingw.h which will gets built from - ;; _mingw.h.in by mingw-w64's configure. We - ;; cannot configure mingw-w64 until we have - ;; xgcc-sans-libc; substitute to the rescue. - (copy-file (string-append mingw-headers - "/crt/_mingw.h.in") - (string-append mingw-headers - "/crt/_mingw.h")) - (substitute* (string-append mingw-headers - "/crt/_mingw.h") - (("@MINGW_HAS_SECURE_API@") - "#define MINGW_HAS_SECURE_API 1")) - (let ((cpath - (string-append - mingw-headers "/include" - ":" mingw-headers "/crt" - ":" mingw-headers "/defaults/include"))) - (for-each (cut setenv <> cpath) - (cons - "CROSS_LIBRARY_PATH" - ',%gcc-cross-include-paths)))) - (when libc - (setenv "CROSS_LIBRARY_PATH" - (string-append - libc "/lib" - ":" libc "/i686-w64-mingw32/lib"))))) - (setenv "CPP" (string-append gcc "/bin/cpp")) - (for-each - (lambda (var) - (and=> - (getenv var) - (lambda (value) - (let* ((path (search-path-as-string->list - value)) - (native-path (list->search-path-as-string - (remove cross? path) ":"))) - (setenv var native-path))))) - (cons "LIBRARY_PATH" ',%gcc-include-paths)) - #t))))) - (libc - `(alist-cons-before - 'configure 'set-cross-path - (lambda* (#:key inputs #:allow-other-keys) - ;; Add the cross kernel headers to CROSS_CPATH, and remove - ;; them from CPATH. - (let ((libc (assoc-ref inputs "libc")) - (kernel (assoc-ref inputs "xkernel-headers"))) - (define (cross? x) - ;; Return #t if X is a cross-libc or cross Linux. - (or (string-prefix? libc x) - (string-prefix? kernel x))) - (let ((cpath (string-append - libc "/include" - ":" kernel "/include"))) - (for-each (cut setenv <> cpath) - ',%gcc-cross-include-paths)) - (setenv "CROSS_LIBRARY_PATH" - (string-append libc "/lib:" - kernel "/lib")) ;for Hurd's libihash - (for-each - (lambda (var) - (and=> - (getenv var) - (lambda (value) - (let* ((path (search-path-as-string->list value)) - (native-path (list->search-path-as-string - (remove cross? path) ":"))) - (setenv var native-path))))) - (cons "LIBRARY_PATH" ',%gcc-include-paths)) - #t)) - ,phases)) - (else phases)))))))) + `(cross-gcc-build-phases ,target ,phases)))))) (define (cross-gcc-patches target) "Return GCC patches needed for TARGET." @@ -336,13 +207,14 @@ GCC that does not target a libc; otherwise, target that libc." (arguments `(#:implicit-inputs? #f + #:imported-modules ((gnu build cross-toolchain) + ,@%gnu-build-system-modules) #:modules ((guix build gnu-build-system) (guix build utils) - (ice-9 ftw) - (ice-9 match) - (ice-9 regex) + (gnu build cross-toolchain) (srfi srfi-1) - (srfi srfi-26)) + (srfi srfi-26) + (ice-9 regex)) ,@(cross-gcc-arguments target libc))) -- cgit v1.2.3 From 974e02da76776f99f7b6a4764dd46e4c131c0de7 Mon Sep 17 00:00:00 2001 From: David Craven Date: Sat, 3 Dec 2016 21:42:32 +0100 Subject: file-systems: Refactor file system detection logic. * gnu/build/file-systems.scm (read-superblock, null-terminated-latin1->string): New variables. (sub-bytevector): Move to general section. (ext2-superblock?, read-ext2-superblock): New variables. (ext2-superblock-uuid, ext2-superblock-volume-name): Use sub-bytevector and null-terminated-latin1->string. (%ext2-sblock-magic, %ext2-sblock-creator-os, %ext2-sblock-uuid, %ext2-sblock-volume-name): Inline constants. (luks-superblock?, read-luks-header): New variables. (%luks-header-size, %luks-magic): Inline. (partition-label-predicate, partition-uuid-predicate, luks-partition-uuid-predicate): Use new functions. --- gnu/build/file-systems.scm | 126 ++++++++++++++++++++------------------------- 1 file changed, 57 insertions(+), 69 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 431b287d0c..c121ca5f8b 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 David Craven ;;; ;;; This file is part of GNU Guix. ;;; @@ -71,67 +72,69 @@ "Bind-mount SOURCE at TARGET." (mount source target "" MS_BIND)) +(define (read-superblock device offset size magic?) + "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw +superblock on success, and #f if no valid superblock was found. MAGIC? +takes a bytevector and returns #t when it's a valid superblock." + (call-with-input-file device + (lambda (port) + (seek port offset SEEK_SET) + + (let ((block (make-bytevector size))) + (match (get-bytevector-n! port block 0 (bytevector-length block)) + ((? eof-object?) + #f) + ((? number? len) + (and (= len (bytevector-length block)) + (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 (null-terminated-latin1->string bv) + "Return the volume name of SBLOCK as a string of at most 256 characters, or +#f if SBLOCK has no volume name." + ;; This is a Latin-1, nul-terminated string. + (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv)))) + (if (null? bytes) + #f + (list->string (map integer->char bytes))))) + ;;; ;;; Ext2 file systems. ;;; +;; . +;; TODO: Use "packed structs" from Guile-OpenGL or similar. + (define-syntax %ext2-endianness ;; Endianness of ext2 file systems. (identifier-syntax (endianness little))) -;; Offset in bytes of interesting parts of an ext2 superblock. See -;; . -;; TODO: Use "packed structs" from Guile-OpenGL or similar. -(define-syntax %ext2-sblock-magic (identifier-syntax 56)) -(define-syntax %ext2-sblock-creator-os (identifier-syntax 72)) -(define-syntax %ext2-sblock-uuid (identifier-syntax 104)) -(define-syntax %ext2-sblock-volume-name (identifier-syntax 120)) +(define (ext2-superblock? sblock) + "Return #t when SBLOCK is an ext2 superblock." + (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness))) + (= magic #xef53))) (define (read-ext2-superblock device) "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f if DEVICE does not contain an ext2 file system." - (define %ext2-magic - ;; The magic bytes that identify an ext2 file system. - #xef53) - - (define superblock-size - ;; Size of the interesting part of an ext2 superblock. - 264) - - (define block - ;; The superblock contents. - (make-bytevector superblock-size)) - - (call-with-input-file device - (lambda (port) - (seek port 1024 SEEK_SET) - - ;; Note: work around . - (and (eqv? superblock-size (get-bytevector-n! port block 0 - superblock-size)) - (let ((magic (bytevector-u16-ref block %ext2-sblock-magic - %ext2-endianness))) - (and (= magic %ext2-magic) - block)))))) + (read-superblock device 1024 264 ext2-superblock?)) (define (ext2-superblock-uuid sblock) "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector." - (let ((uuid (make-bytevector 16))) - (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16) - uuid)) + (sub-bytevector sblock 104 16)) (define (ext2-superblock-volume-name sblock) "Return the volume name of SBLOCK as a string of at most 16 characters, or #f if SBLOCK has no volume name." - (let ((bv (make-bytevector 16))) - (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16) + (null-terminated-latin1->string (sub-bytevector sblock 120 16))) - ;; This is a Latin-1, nul-terminated string. - (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv)))) - (if (null? bytes) - #f - (list->string (map integer->char bytes)))))) ;;; @@ -146,37 +149,22 @@ if DEVICE does not contain an ext2 file system." ;; Endianness of LUKS headers. (identifier-syntax (endianness big))) -(define-syntax %luks-header-size - ;; Size in bytes of the LUKS header, including key slots. - (identifier-syntax 592)) - -(define %luks-magic - ;; The 'LUKS_MAGIC' constant. - (u8-list->bytevector (append (map char->integer (string->list "LUKS")) - (list #xba #xbe)))) - -(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 (luks-superblock? sblock) + "Return #t when SBLOCK is a luks superblock." + (define %luks-magic + ;; The 'LUKS_MAGIC' constant. + (u8-list->bytevector (append (map char->integer (string->list "LUKS")) + (list #xba #xbe)))) + (let ((magic (sub-bytevector sblock 0 6)) + (version (bytevector-u16-ref sblock 6 %luks-endianness))) + (and (bytevector=? magic %luks-magic) + (= version 1)))) (define (read-luks-header file) "Read a LUKS header from FILE. Return the raw header on success, and #f if not valid header was found." - (call-with-input-file file - (lambda (port) - (let ((header (make-bytevector %luks-header-size))) - (match (get-bytevector-n! port header 0 (bytevector-length header)) - ((? eof-object?) - #f) - ((? number? len) - (and (= len (bytevector-length header)) - (let ((magic (sub-bytevector header 0 6)) ;XXX: inefficient - (version (bytevector-u16-ref header 6 %luks-endianness))) - (and (bytevector=? magic %luks-magic) - (= version 1) - header))))))))) + ;; Size in bytes of the LUKS header, including key slots. + (read-superblock file 0 592 luks-superblock?)) (define (luks-header-uuid header) "Return the LUKS UUID from HEADER, as a 16-byte bytevector." @@ -267,7 +255,7 @@ returns #t if that partition's volume name is LABEL." ext2-superblock-uuid bytevector=?)) -(define partition-luks-uuid-predicate +(define luks-partition-uuid-predicate (partition-predicate read-luks-header luks-header-uuid bytevector=?)) @@ -289,7 +277,7 @@ or #f if none was found." (define (find-partition-by-luks-uuid uuid) "Return the first LUKS partition whose unique identifier is UUID (a bytevector), or #f if none was found." - (and=> (find (partition-luks-uuid-predicate uuid) + (and=> (find (luks-partition-uuid-predicate uuid) (disk-partitions)) (cut string-append "/dev/" <>))) -- cgit v1.2.3