;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès ;;; ;;; 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 (test-challenge) #:use-module (guix tests) #:use-module (guix tests http) #:use-module ((gcrypt hash) #:prefix gcrypt:) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix serialization) #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix base32) #:use-module (guix narinfo) #:use-module (guix scripts challenge) #:use-module ((guix build utils) #:select (find-files)) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match)) (define query-path-hash* (store-lift query-path-hash)) (define (query-path-size item) (mlet %store-monad ((info (query-path-info* item))) (return (path-info-nar-size info)))) (define* (call-with-derivation-narinfo* drv thunk hash) (lambda (store) (with-derivation-narinfo drv (sha256 => hash) (values (run-with-store store (thunk)) store)))) (define-syntax with-derivation-narinfo* (syntax-rules (sha256 =>) ((_ drv (sha256 => hash) body ...) (call-with-derivation-narinfo* drv (lambda () body ...) hash)))) (test-begin "challenge") (test-assertm "no discrepancies" (let ((text (random-text))) (mlet* %store-monad ((drv (gexp->derivation "something" #~(call-with-output-file #$output (lambda (port) (display #$text port))))) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet %store-monad ((hash (query-path-hash* out))) (with-derivation-narinfo* drv (sha256 => hash) (>>= (compare-contents (list out) (%test-substitute-urls)) (match-lambda ((report) (return (and (string=? out (comparison-report-item report)) (bytevector=? (comparison-report-local-sha256 report) hash) (comparison-report-match? report)))))))))))) (test-assertm "one discrepancy" (let ((text (random-text))) (mlet* %store-monad ((drv (gexp->derivation "something" #~(call-with-output-file #$output (lambda (port) (display #$text port))))) (out -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) (mlet* %store-monad ((hash (query-path-hash* out)) (wrong-hash -> (let* ((w (bytevector-copy hash)) (b (bytevector-u8-ref w 0))) (bytevector-u8-set! w 0 (modulo (+ b 1) 128)) w))) (with-derivation-narinfo* drv (sha256 => wrong-hash) (>>= (compare-contents (list out) (%test-substitute-urls)) (match-l2022-12-07bootloaders: grub: Fix comment....* gnu/bootloader/grub.scm (make-grub-configuration): Refer to the correct argument in comment. Maxim Cournoyer 2022-12-01gnu: bootloader: Rework chaining, add grub-efi-netboot-removable-bootloader....This rework allows to use an (efi-bootloader-chain) like this, which is able to boot over network or local storage, depending on whether the bootloader target has support for symbolic links: (operating-system (bootloader (bootloader-configuration (bootloader (efi-bootloader-chain grub-efi-netboot-removable-bootloader #:packages (list my-firmware-package my-u-boot-package) #:files (list (plain-file "config.txt" "kernel=u-boot.bin")) #:hooks my-special-bootloader-profile-manipulator)) (targets '("/booti/efi")) …)) …) * doc/guix.texi (Bootloader Configuration): Describe the new ‘grub-efi-netboot-removable-bootloader’. Mention the file names used and that the UEFI Boot Manager is not modified. Advise to disable write-access over TFTP. * gnu/bootloader.scm (efi-bootloader-profile): Allow a list of packages and collect everything directly in the profile, avoiding a separate collection directory. Renamed the profile from "bootloader-profile" to "efi-bootloader-profile". [bootloader-collection]: Rename to... [efi-bootloader-profile-hook]: ... this and remove unused modules. Do not create the now extraneous collection directory. (efi-bootloader-chain): Add PACKAGES and DISK-IMAGE-INSTALLER arguments. Remove handling of the collection directory, now only calling the given installer procedure. * gnu/bootloader/grub.scm (make-grub-efi-netboot-installer): New helper. (make-grub-configuration): New helper based on (grub-configuration-file). Add a GRUB argument, fix indentation, remove previous code retrieving GRUB from CONFIG. (grub-configuration-file): Make use of make-grub-configuration. (grub-efi-configuration-file): New procedure. (grub-cfg): New variable to replace "/boot/grub/grub.cfg". (install-grub-efi-netboot): Remove, splitting logic to... (make-grub-efi-netboot-installer): ... this new helper procedure, as well as to make-grub-efi-netboot, added below. (grub-bootloader): Adjust to use the GRUB-CFG. (grub-efi-bootloader): Likewise. Removed inheritance and declare all fields explicitly. (make-grub-efi-netboot-bootloader): New procedure. (grub-efi-netboot-bootloader): Use it. (grub-efi-netboot-removable-bootloader): New variable. * gnu/packages/bootloaders.scm (make-grub-efi-netboot): New procedure. Signed-off-by: Maxim Cournoyer <maxim.cournoyer@gmail.com> Modified-by: Maxim Cournoyer <maxim.cournoyer@gmail.com> Stefan d #$output "/bin/guile") #o755) (call-with-output-file (string-append #$output "/bin/guile") (lambda (port) (display "corrupt!" port))))))) (out1 -> (derivation->output-path drv1)) (out2 -> (derivation->output-path drv2)) (item -> (string-append (%store-prefix) "/" (bytevector->nix-base32-string (random-bytevector 32)) "-foo" (number->string (current-time) 16)))) (mbegin %store-monad (built-derivations (list drv1 drv2)) (mlet* %store-monad ((size1 (query-path-size out1)) (size2 (query-path-size out2)) (hash1 (query-path-hash* out1)) (hash2 (query-path-hash* out2)) (nar1 -> (call-with-bytevector-output-port (lambda (port) (write-file out1 port)))) (nar2 -> (call-with-bytevector-output-port (lambda (port) (write-file out2 port))))) (parameterize ((%http-server-port 9000)) (with-http-server `((200 ,(make-narinfo item size1 hash1)) (200 ,nar1)) (parameterize ((%http-server-port 9001)) (with-http-server `((200 ,(make-narinfo item size2 hash2)) (200 ,nar2)) (mlet* %store-monad ((urls -> (list (%local-url 9000) (%local-url 9001))) (reports (compare-contents (list item) urls))) (pk 'report reports) (return (proc (car reports)))))))))))) (test-assertm "differing-files" (call-mismatch-test (lambda (report) (equal? (differing-files report) '("/bin/guile"))))) (test-assertm "call-with-mismatches" (call-mismatch-test (lambda (report) (call-with-mismatches report (lambda (directory1 directory2) (let* ((files1 (find-files directory1)) (files2 (find-files directory2)) (files (map (cute string-drop <> (string-length directory1)) files1))) (and (equal? files (map (cute string-drop <> (string-length directory2)) files2)) (equal? (remove (lambda (file) (file=? (string-append directory1 "/" file) (string-append directory2 "/" file))) files) '("/bin/guile"))))))))) (test-end) ;;; Local Variables: ;;; eval: (put 'with-derivation-narinfo* 'scheme-indent-function 2) ;;; End: