;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 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-store) #:use-module (guix tests) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix monads) #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix serialization) #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) ;; Test the (guix store) module. (define %store (open-connection-for-tests)) (define %shell (or (getenv "SHELL") (getenv "CONFIG_SHELL"))) (test-begin "store") (test-assert "open-connection with file:// URI" (let ((store (open-connection (string-append "file://" (%daemon-socket-uri))))) (and (add-text-to-store store "foo" "bar") (begin ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; 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 services configuration) #:use-module (guix packages) #:use-module (guix records) #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) #:use-module ((guix diagnostics) #:select (formatted-message location-file &error-location warning)) #:use-module ((guix modules) #:select (file-name->module-name)) #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) #:autoload (texinfo serialize) (stexi->texi) #:use-module (ice-9 curried-definitions) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-171) #:export (configuration-field configuration-field-name configuration-field-type configuration-missing-field configuration-field-error configuration-field-sanitizer configuration-field-serializer configuration-field-getter configuration-field-default-value-thunk configuration-field-documentation configuration-error? define-configuration define-configuration/no-serialization no-serialization empty-serializer? tfilter-maybe-value base-transducer serialize-configuration define-maybe define-maybe/no-serialization %unset-value maybe-value maybe-value-set? generate-documentation configuration->documentation empty-serializer serialize-package filter-configuration-fields interpose list-of list-of-packages? list-of-strings? list-of-symbols? alist? serialize-file-like text-config? serialize-text-config generic-serialize-alist-entry generic-serialize-alist)) ;;; Commentary: ;;; ;;; Syntax for creating Scheme bindings to complex configuration files. ;;; ;;; Code: (define-condition-type &configuration-error &error configuration-error?) (define (configuration-error message) (raise (condition (&message (message message)) (&configuration-error)))) (define (configuration-field-error loc field value) (raise (apply make-compound-condition (formatted-message (G_ "invalid value ~s for field '~a'") value field) (condition (&configuration-error)) (if loc (list (condition (&error-location (location loc)))) '())))) (define (configuration-missing-field kind field) (configuration-error (format #f "~a configuration missing required field ~a" kind field))) (define (configuration-missing-default-value kind field) (configuration-error (format #f "The field `~a' of the `~a' configuration record \ does not have a default value" field kind))) (define-record-type* <configuration-field> configuration-field make-configuration-field configuration-field? (name configuration-field-name) (type configuration-field-type) (getter configuration-field-getter) (predicate configuration-field-predicate) (sanitizer configuration-field-sanitizer) (serializer configuration-field-serializer) (default-value-thunk configuration-field-default-value-thunk) (documentation configuration-field-documentation)) (define (empty-serializer? field) "Predicate that checks whether FIELD is exempt from serialization." (eq? empty-serializer (configuration-field-serializer field))) (define (tfilter-maybe-value config) "Return a transducer for CONFIG that removes all maybe-type fields whose value is '%unset-marker." (tfilter (lambda (field) (let ((field-value ((configuration-field-getter field) config))) (maybe-value-set? field-value))))) (define (base-transducer config) "Return a transducer for CONFIG that calls the serializing procedures only for fields marked for serialization and whose values are not '%unset-marker." (compose (tremove empty-serializer?) ;; Only serialize fields whose value isn't '%unset-marker%. (tfilter-maybe-value config) (tmap (lambda (field) ((configuration-field-serializer field) (configuration-field-name field) ((configuration-field-getter field) config)))))) (define (serialize-configuration config fields) "Return a G-expression that contains the values corresponding to the FIELDS of CONFIG, a record that has been generated by `define-configuration'. The G-expression can then be serialized to disk by using something like `mixed-text-file'." #~(string-append #$@(list-transduce (base-transducer config) rcons fields))) (define-syntax-rule (id ctx parts ...) "Assemble PARTS into a raw (unhygienic) identifier." (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) (define (define-maybe-helper serialize? prefix syn) (syntax-case syn () ((_ stem) (with-syntax ((stem? (id #'stem #'stem #'?)) (maybe-stem? (id #'stem #'maybe- #'stem #'?)) (serialize-stem (if prefix (id #'stem prefix #'serialize- #'stem) (id #'stem #'serialize- #'stem))) (serialize-maybe-stem (if prefix (id #'stem prefix #'serialize-maybe- #'stem) (id #'stem #'serialize-maybe- #'stem)))) #`(begin (define (maybe-stem? val) (or (not (maybe-value-set? val)) (stem? val))) #,@(if serialize? (list #'(define (serialize-maybe-stem field-name val) (if (stem? val) (serialize-stem field-name val) ""))) '())))))) (define-syntax define-maybe (lambda (x) (syntax-case x (no-serialization prefix) ((_ stem (no-serialization)) (define-maybe-helper #f #f #'(_ stem))) ((_ stem (prefix serializer-prefix)) (define-maybe-helper #t #'serializer-prefix #'(_ stem))) ((_ stem) (define-maybe-helper #t #f #'(_ stem)))))) (define-syntax-rule (define-maybe/no-serialization stem) (define-maybe stem (no-serialization))) (define (normalize-field-type+def s) (syntax-case s () ((field-type def) (identifier? #'field-type) (values #'(field-type def))) ((field-type) (identifier? #'field-type) (values #'(field-type %unset-value))) (field-type (identifier? #'field-type) (values #'(field-type %unset-value))))) (define (define-configuration-helper serialize? serializer-prefix syn) (define (normalize-extra-args s) "Extract and normalize arguments following @var{doc}." (let loop ((s s) (sanitizer* #f) (serializer* #f)) (syntax-case s (sanitizer serializer empty-serializer) (((sanitizer proc) tail ...) (if sanitizer* (syntax-violation 'sanitizer "duplicate entry" #'proc) (loop #'(tail ...) #'proc serializer*))) (((serializer proc) tail ...) (if serializer* (syntax-violation 'serializer "duplicate or conflicting entry" #'proc) (loop #'(tail ...) sanitizer* #'proc))) ((empty-serializer tail ...) (if serializer* (syntax-violation 'empty-serializer "duplicate or conflicting entry" #f) (loop #'(tail ...) sanitizer* #'empty-serializer))) (() ; stop condition (values (list sanitizer* serializer*))) ((proc) ; TODO: deprecated, to be removed. (not (or sanitizer* serializer*)) (begin (warning #f (G_ "specifying serializers after documentation is \ deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc)) (values (list #f #'proc))))))) (syntax-case syn () ((_ stem (field field-type+def doc extra-args ...) ...) (with-syntax ((((field-type def) ...) (map normalize-field-type+def #'(field-type+def ...))) (((sanitizer* serializer*) ...) (map normalize-extra-args #'((extra-args ...) ...)))) (with-syntax (((field-getter ...) (map (lambda (field) (id #'stem #'stem #'- field)) #'(field ...))) ((field-predicate ...) (map (lambda (type) (id #'stem type #'?)) #'(field-type ...))) ((field-default ...) (map (match-lambda ((field-type default-value) default-value)) #'((field-type def) ...))) ((field-sanitizer ...) #'(sanitizer* ...)) ((field-serializer ...) (map (lambda (type proc) (and serialize? (or proc (if serializer-prefix (id #'stem serializer-prefix #'serialize- type) (id #'stem #'serialize- type))))) #'(field-type ...) #'(serializer* ...)))) (define (default-field-sanitizer name pred) ;; Define a macro for use as a record field sanitizer, where NAME ;; is the name of the field and PRED is the predicate that tells ;; whether a value is valid for this field. #`(define-syntax #,(id #'stem #'validate- #'stem #'- name) (lambda (s) ;; Make sure the given VALUE, for field NAME, passes PRED. (syntax-case s () ((_ value) (with-syntax ((name #'#,name) (pred #'#,pred) (loc (datum->syntax #'value (syntax-source #'value)))) #'(if (pred value) value (configuration-field-error (and=> 'loc source-properties->location) 'name value)))))))) #`(begin ;; Define field validation macros. #,@(filter-map (lambda (name pred sanitizer) (if sanitizer #f (default-field-sanitizer name pred))) #'(field ...) #'(field-predicate ...) #'(field-sanitizer ...)) (define-record-type* #,(id #'stem #'< #'stem #'>) stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) #,@(map (lambda (name getter def sanitizer) #`(#,name #,getter (default #,def) (sanitize #,(or sanitizer (id #'stem #'validate- #'stem #'- name))))) #'(field ...) #'(field-getter ...) #'(field-default ...) #'(field-sanitizer ...)) (%location #,(id #'stem #'stem #'-source-location) (default (and=> (current-source-location) source-properties->location)) (innate))) (define #,(id #'stem #'stem #'-fields) (list (configuration-field (name 'field) (type 'field-type) (getter field-getter) (predicate field-predicate) (sanitizer (or field-sanitizer (id #'stem #'validate- #'stem #'- #'field))) (serializer field-serializer) (default-value-thunk (lambda () (if (maybe-value-set? (syntax->datum field-default)) field-default (configuration-missing-default-value '#,(id #'stem #'% #'stem) 'field)))) (documentation doc)) ...)))))))) (define no-serialization ;syntactic keyword for 'define-configuration' '(no serialization)) (define-syntax define-configuration (lambda (s) (syntax-case s (no-serialization prefix) ((_ stem (field field-type+def doc custom-serializer ...) ... (no-serialization)) (define-configuration-helper #f #f #'(_ stem (field field-type+def doc custom-serializer ...) ...))) ((_ stem (field field-type+def doc custom-serializer ...) ... (prefix serializer-prefix)) (define-configuration-helper #t #'serializer-prefix #'(_ stem (field field-type+def doc custom-serializer ...) ...))) ((_ stem (field field-type+def doc custom-serializer ...) ...) (define-configuration-helper #t #f #'(_ stem (field field-type+def doc custom-serializer ...) ...)))))) (define-syntax-rule (define-configuration/no-serialization stem (field field-type+def doc custom-serializer ...) ...) (define-configuration stem (field field-type+def doc custom-serializer ...) ... (no-serialization))) (define (empty-serializer field-name val) "") (define serialize-package empty-serializer) ;; Ideally this should be an implementation detail, but we export it ;; to provide a simpler API that enables unsetting a configuration ;; field that has a maybe type, but also a default value. We give it ;; a value that sticks out to the reader when something goes wrong. ;; ;; An example use-case would be something like a network application ;; that uses a default port, but the field can explicitly be unset to ;; request a random port at startup. (define %unset-value '%unset-marker%) (define (maybe-value-set? value) "Predicate to check whether a 'maybe' value was explicitly provided." (not (eq? %unset-value value))) ;; Ideally there should be a compiler macro for this predicate, that expands ;; to a conditional that only instantiates the default value when needed. (define* (maybe-value value #:optional (default #f)) "Returns VALUE, unless it is the unset value, in which case it returns DEFAULT." (if (maybe-value-set? value) value default)) ;; A little helper to make it easier to document all those fields. (define (generate-documentation documentation documentation-name) (define (str x) (object->string x)) (define (package->symbol package) "Return the first symbol name of a package that matches PACKAGE, else #f." (let* ((module (file-name->module-name (location-file (package-location package)))) (symbols (filter-map identity (module-map (lambda (symbol var) (and (equal? package (variable-ref var)) symbol)) (resolve-module module))))) (if (null? symbols) #f (first symbols)))) (define (generate configuration-name) (match (assq-ref documentation configuration-name) ((fields . sub-documentation) `((deftp (% (category "Data Type") (name ,(str configuration-name))) (para "Available " (code ,(str configuration-name)) " fields are:") (table (% (formatter (asis))) ,@(map (lambda (f) (let ((field-name (configuration-field-name f)) (field-type (configuration-field-type f)) (field-docs (cdr (texi-fragment->stexi (configuration-field-documentation f)))) (default (catch #t (configuration-field-default-value-thunk f) (lambda _ '%invalid)))) (define (show-default? val) (or (string? val) (number? val) (boolean? val) (package? val) (and (symbol? val) (not (eq? val '%invalid))) (and (list? val) (and-map show-default? val)))) (define (show-default val) (cond ((package? val) (symbol->string (package->symbol val))) (((list-of package?) val) (format #f "(~{~a~^ ~})" (map package->symbol val))) (else (str val)))) `(entry (% (heading (code ,(str field-name)) ,@(if (show-default? default) `(" (default: " (code ,(show-default default)) ")") '()) " (type: " ,(str field-type) ")")) (para ,@field-docs) ,@(append-map generate (or (assq-ref sub-documentation field-name) '()))))) fields))))))) (stexi->texi `(*fragment* . ,(generate documentation-name)))) (define (configuration->documentation configuration-symbol) "Take CONFIGURATION-SYMBOL, the symbol corresponding to the name used when defining a configuration record with DEFINE-CONFIGURATION, and output the Texinfo documentation of its fields." ;; This is helper for a simple, straight-forward application of ;; GENERATE-DOCUMENTATION. (let ((fields-getter (module-ref (current-module) (symbol-append configuration-symbol '-fields)))) (display (generate-documentation `((,configuration-symbol ,fields-getter)) configuration-symbol)))) (define* (filter-configuration-fields configuration-fields fields #:optional negate?) "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS. If NEGATE? is @code{#t}, retrieve all fields except FIELDS." (filter (lambda (field) (let ((member? (member (configuration-field-name field) fields))) (if (not negate?) member? (not member?)))) configuration-fields)) (define* (interpose ls #:optional (delimiter "\n") (grammar 'infix)) "Same as @code{string-join}, but without join and string, returns a DELIMITER interposed LS. Support 'infix and 'suffix GRAMMAR values." (when (not (member grammar '(infix suffix))) (raise (formatted-message (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.") grammar))) (fold-right (lambda (e acc) (cons e (if (and (null? acc) (eq? grammar 'infix)) acc (cons delimiter acc)))) '() ls)) ;;; ;;; Commonly used predicates ;;; (define (list-of pred?) "Return a procedure that takes a list and check if all the elements of the list result in @code{#t} when applying PRED? on them." (lambda (x) (if (list? x) (every pred? x) #f))) (define list-of-packages? (list-of package?)) (define list-of-strings? (list-of string?)) (define list-of-symbols? (list-of symbol?)) ;;; ;;; Special serializers ;;; (define alist? (list-of pair?)) (define serialize-file-like empty-serializer) (define (text-config? config) (list-of file-like?)) (define (serialize-text-config field-name val) #~(string-append #$@(interpose (map (lambda (e) #~(begin (use-modules (ice-9 rdelim)) (with-fluids ((%default-port-encoding "UTF-8")) (with-input-from-file #$e read-string)))) val) "\n" 'suffix))) (define ((generic-serialize-alist-entry serialize-field) entry) "Apply the SERIALIZE-FIELD procedure on the field and value of ENTRY." (match entry ((field . val) (serialize-field field val)))) (define (generic-serialize-alist combine serialize-field fields) "Generate a configuration from an association list FIELDS. SERIALIZE-FIELD is a procedure that takes two arguments, it will be applied on the fields and values of FIELDS using the @code{generic-serialize-alist-entry} procedure. COMBINE is a procedure that takes one or more arguments and combines all the alist entries into one value, @code{string-append} or @code{append} are usually good candidates for this." (apply combine (map (generic-serialize-alist-entry serialize-field) fields)))
generated by cgit
the daemon writes "hash mismatch in downloaded ;; path", but the actual error returned to the client ;; doesn't mention that. (pk 'corrupt c) (not (zero? (nix-protocol-error-status c))))) (build-derivations s (list d)) #f)))))) (test-assert "substitute --fallback" (with-store s (let* ((t (random-text)) ; contents of the output (d (build-expression->derivation s "substitute-me-not" `(call-with-output-file %output (lambda (p) (display ,t p))) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (guard (c ((nix-protocol-error? c) ;; The substituter failed as expected. Now make ;; sure that #:fallback? #t works correctly. (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls) #:fallback? #t) (and (build-derivations s (list d)) (equal? t (call-with-input-file o get-string-all))))) ;; Should fail. (build-derivations s (list d)) #f)))))) (test-assert "export/import several paths" (let* ((texts (unfold (cut >= <> 10) (lambda _ (random-text)) 1+ 0)) (files (map (cut add-text-to-store %store "text" <>) texts)) (dump (call-with-bytevector-output-port (cut export-paths %store files <>)))) (delete-paths %store files) (and (every (negate file-exists?) files) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) (and (equal? imported files) (every file-exists? files) (equal? texts (map (lambda (file) (call-with-input-file file get-string-all)) files))))))) (test-assert "export/import paths, ensure topological order" (let* ((file0 (add-text-to-store %store "baz" (random-text))) (file1 (add-text-to-store %store "foo" (random-text) (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (files (list file1 file2)) (dump1 (call-with-bytevector-output-port (cute export-paths %store (list file1 file2) <>))) (dump2 (call-with-bytevector-output-port (cute export-paths %store (list file2 file1) <>)))) (delete-paths %store files) (and (every (negate file-exists?) files) (bytevector=? dump1 dump2) (let* ((source (open-bytevector-input-port dump1)) (imported (import-paths %store source))) ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0. (and (equal? imported (list file1 file2)) (every file-exists? files) (equal? (list file0) (references %store file1)) (equal? (list file1) (references %store file2))))))) (test-assert "export/import incomplete" (let* ((file0 (add-text-to-store %store "baz" (random-text))) (file1 (add-text-to-store %store "foo" (random-text) (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (dump (call-with-bytevector-output-port (cute export-paths %store (list file2) <>)))) (delete-paths %store (list file0 file1 file2)) (guard (c ((nix-protocol-error? c) (and (not (zero? (nix-protocol-error-status c))) (string-contains (nix-protocol-error-message c) "not valid")))) ;; Here we get an exception because DUMP does not include FILE0 and ;; FILE1, which are dependencies of FILE2. (import-paths %store (open-bytevector-input-port dump))))) (test-assert "export/import recursive" (let* ((file0 (add-text-to-store %store "baz" (random-text))) (file1 (add-text-to-store %store "foo" (random-text) (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (dump (call-with-bytevector-output-port (cute export-paths %store (list file2) <> #:recursive? #t)))) (delete-paths %store (list file0 file1 file2)) (let ((imported (import-paths %store (open-bytevector-input-port dump)))) (and (equal? imported (list file0 file1 file2)) (every file-exists? (list file0 file1 file2)) (equal? (list file0) (references %store file1)) (equal? (list file1) (references %store file2)))))) (test-assert "write-file & export-path yield the same result" ;; Here we compare 'write-file' and the daemon's own implementation. ;; 'write-file' is the reference because we know it sorts file ;; deterministically. Conversely, the daemon uses 'readdir' and the entries ;; currently happen to be sorted as a side-effect of some unrelated ;; operation (search for 'unhacked' in archive.cc.) Make sure we detect any ;; changes there. (run-with-store %store (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile)) (out1 -> (derivation->output-path drv1)) (data -> (unfold (cut >= <> 26) (lambda (i) (random-bytevector 128)) 1+ 0)) (build -> #~(begin (use-modules (rnrs io ports) (srfi srfi-1)) (let () (define letters (map (lambda (i) (string (integer->char (+ i (char->integer #\a))))) (iota 26))) (define (touch file data) (call-with-output-file file (lambda (port) (put-bytevector port data)))) (mkdir #$output) (chdir #$output) ;; The files must be different so they have ;; different inode numbers, and the inode ;; order must differ from the lexicographic ;; order. (for-each touch (append (drop letters 10) (take letters 10)) (list #$@data)) #t))) (drv2 (gexp->derivation "bunch" build)) (out2 -> (derivation->output-path drv2)) (item-info -> (store-lift query-path-info))) (mbegin %store-monad (built-derivations (list drv1 drv2)) (foldm %store-monad (lambda (item result) (define ref-hash (let-values (((port get) (open-sha256-port))) (write-file item port) (close-port port) (get))) ;; 'query-path-info' returns a hash produced by using the ;; daemon's C++ 'dump' function, which is the implementation ;; under test. (>>= (item-info item) (lambda (info) (return (and result (bytevector=? (path-info-hash info) ref-hash)))))) #t (list out1 out2)))) #:guile-for-build (%guile-for-build))) (test-assert "import corrupt path" (let* ((text (random-text)) (file (add-text-to-store %store "text" text)) (dump (call-with-bytevector-output-port (cut export-paths %store (list file) <>)))) (delete-paths %store (list file)) ;; Flip a bit in the stream's payload. INDEX here falls in the middle of ;; the file contents in DUMP, regardless of the store prefix. (let* ((index #x70) (byte (bytevector-u8-ref dump index))) (bytevector-u8-set! dump index (logxor #xff byte))) (and (not (file-exists? file)) (guard (c ((nix-protocol-error? c) (pk 'c c) (and (not (zero? (nix-protocol-error-status c))) (string-contains (nix-protocol-error-message c) "corrupt")))) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) (pk 'corrupt-imported imported) #f))))) (test-assert "verify-store" (let* ((text (random-text)) (file1 (add-text-to-store %store "foo" text)) (file2 (add-text-to-store %store "bar" (random-text) (list file1)))) (and (pk 'verify1 (verify-store %store)) ;hopefully OK ; (begin (delete-file file1) (not (pk 'verify2 (verify-store %store)))) ;bad! ; (begin ;; Using 'add-text-to-store' here wouldn't work: It would succeed ; ;; without actually creating the file. ; (call-with-output-file file1 (lambda (port) (display text port))) (pk 'verify3 (verify-store %store)))))) ;OK again (test-assert "verify-store + check-contents" ;; XXX: This test is I/O intensive. (with-store s (let* ((text (random-text)) (drv (build-expression->derivation s "corrupt" `(let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) (display ,text port))) #t) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) (with-derivation-substitute drv text (and (build-derivations s (list drv)) (verify-store s #:check-contents? #t) ;should be OK (begin (chmod file #o644) (call-with-output-file file (lambda (port) (display "corrupt!" port))) #t) ;; Make sure the corruption is detected. We don't test repairing ;; because only "trusted" users are allowed to do it, but we ;; don't expose that notion of trusted users that nix-daemon ;; supports because it seems dubious and redundant with what the ;; OS provides (in Nix "trusted" users have additional ;; privileges, such as overriding the set of substitute URLs, but ;; we instead want to allow anyone to modify them, provided ;; substitutes are signed by a root-approved key.) (not (verify-store s #:check-contents? #t)) ;; Delete the corrupt item to leave the store in a clean state. (delete-paths s (list file))))))) (test-assert "build-things, check mode" (with-store store (call-with-temporary-output-file (lambda (entropy entropy-port) (write (random-text) entropy-port) (force-output entropy-port) (let* ((drv (build-expression->derivation store "non-deterministic" `(begin (use-modules (rnrs io ports)) (let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) ;; Rely on the fact that tests do not use the ;; chroot, and thus ENTROPY is readable. (display (call-with-input-file ,entropy get-string-all) port))) #t)) #:guile-for-build (package-derivation store %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) (and (build-things store (list (derivation-file-name drv))) (begin (write (random-text) entropy-port) (force-output entropy-port) (guard (c ((nix-protocol-error? c) (pk 'determinism-exception c) (and (not (zero? (nix-protocol-error-status c))) (string-contains (nix-protocol-error-message c) "deterministic")))) ;; This one will produce a different result. Since we're in ;; 'check' mode, this must fail. (build-things store (list (derivation-file-name drv)) (build-mode check)) #f)))))))) (test-assert "build multiple times" (with-store store ;; Ask to build twice. (set-build-options store #:rounds 2 #:use-substitutes? #f) (call-with-temporary-output-file (lambda (entropy entropy-port) (write (random-text) entropy-port) (force-output entropy-port) (let* ((drv (build-expression->derivation store "non-deterministic" `(begin (use-modules (rnrs io ports)) (let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) ;; Rely on the fact that tests do not use the ;; chroot, and thus ENTROPY is accessible. (display (call-with-input-file ,entropy get-string-all) port) (call-with-output-file ,entropy (lambda (port) (write 'foobar port))))) #t)) #:guile-for-build (package-derivation store %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) (guard (c ((nix-protocol-error? c) (pk 'multiple-build c) (and (not (zero? (nix-protocol-error-status c))) (string-contains (nix-protocol-error-message c) "deterministic")))) ;; This one will produce a different result on the second run. (current-build-output-port (current-error-port)) (build-things store (list (derivation-file-name drv))) #f)))))) (test-equal "store-lower" "Lowered." (let* ((add (store-lower text-file)) (file (add %store "foo" "Lowered."))) (call-with-input-file file get-string-all))) (test-equal "current-system" "bar" (parameterize ((%current-system "frob")) (run-with-store %store (mbegin %store-monad (set-current-system "bar") (current-system)) #:system "foo"))) (test-assert "query-path-info" (let* ((ref (add-text-to-store %store "ref" "foo")) (item (add-text-to-store %store "item" "bar" (list ref))) (info (query-path-info %store item))) (and (equal? (path-info-references info) (list ref)) (equal? (path-info-hash info) (sha256 (string->utf8 (call-with-output-string (cut write-file item <>)))))))) (test-assert "path-info-deriver" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s)))) (o (derivation->output-path d))) (and (build-derivations %store (list d)) (not (path-info-deriver (query-path-info %store b))) (string=? (derivation-file-name d) (path-info-deriver (query-path-info %store o)))))) (test-equal "build-cores" (list 0 42) (with-store store (let* ((build (add-text-to-store store "build.sh" "echo $NIX_BUILD_CORES > $out")) (bash (add-to-store store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (drv1 (derivation store "the-thing" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("x" . ,(random-text))))) (drv2 (derivation store "the-thing" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("x" . ,(random-text)))))) (and (build-derivations store (list drv1)) (begin (set-build-options store #:build-cores 42) (build-derivations store (list drv2))) (list (call-with-input-file (derivation->output-path drv1) read) (call-with-input-file (derivation->output-path drv2) read)))))) (test-equal "multiplexed-build-output" '("Hello from first." "Hello from second.") (with-store store (let* ((build (add-text-to-store store "build.sh" "echo Hello from $NAME.; echo > $out")) (bash (add-to-store store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (drv1 (derivation store "one" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("NAME" . "first") ("x" . ,(random-text))))) (drv2 (derivation store "two" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("NAME" . "second") ("x" . ,(random-text)))))) (set-build-options store #:print-build-trace #t #:multiplexed-build-output? #t #:max-build-jobs 10) (let ((port (open-output-string))) ;; Send the build log to PORT. (parameterize ((current-build-output-port port)) (build-derivations store (list drv1 drv2))) ;; Retrieve the build log; make sure it contains valid "@ build-log" ;; traces that allow us to retrieve each builder's output (we assume ;; there's exactly one "build-output" trace for each builder, which is ;; reasonable.) (let* ((log (get-output-string port)) (started (fold-matches (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)") log '() cons)) (done (fold-matches (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)") log '() cons)) (output (fold-matches (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n") log '() cons)) (drv-pid (lambda (name) (lambda (m) (let ((drv (match:substring m 1)) (pid (string->number (match:substring m 4)))) (and (string-suffix? name drv) pid))))) (pid-log (lambda (pid) (lambda (m) (let ((n (string->number (match:substring m 1))) (len (string->number (match:substring m 2))) (str (match:substring m 3))) (and (= pid n) (= (string-length str) (- len 1)) str))))) (pid1 (any (drv-pid "one.drv") started)) (pid2 (any (drv-pid "two.drv") started))) (list (any (pid-log pid1) output) (any (pid-log pid2) output))))))) (test-end "store")