diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 45 | ||||
| -rw-r--r-- | guix/scripts/challenge.scm | 221 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 63 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 7 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 36 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 14 |
6 files changed, 302 insertions, 84 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 3318ef0889..2b4d39c7b8 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -21,7 +21,8 @@ #:use-module (guix utils) #:use-module (guix combinators) #:use-module ((guix build utils) #:select (mkdir-p)) - #:use-module ((guix serialization) #:select (restore-file)) + #:use-module ((guix serialization) + #:select (fold-archive restore-file)) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix grafts) @@ -43,6 +44,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) #:export (guix-archive options->derivations+files)) @@ -76,6 +78,8 @@ Export/import one or more packages from/to the store.\n")) --missing print the files from stdin that are missing")) (display (G_ " -x, --extract=DIR extract the archive on stdin to DIR")) + (display (G_ " + -t, --list list the files in the archive on stdin")) (newline) (display (G_ " --generate-key[=PARAMETERS] @@ -137,6 +141,9 @@ Export/import one or more packages from/to the store.\n")) (option '("extract" #\x) #t #f (lambda (opt name arg result) (alist-cons 'extract arg result))) + (option '("list" #\t) #f #f + (lambda (opt name arg result) + (alist-cons 'list #t result))) (option '("generate-key") #f #t (lambda (opt name arg result) (catch 'gcry-error @@ -319,6 +326,40 @@ the input port." (with-atomic-file-output %acl-file (cut write-acl acl <>))))) +(define (list-contents port) + "Read a nar from PORT and print the list of files it contains to the current +output port." + (define (consume-input port size) + (let ((bv (make-bytevector 32768))) + (let loop ((total size)) + (unless (zero? total) + (let ((n (get-bytevector-n! port bv 0 + (min total (bytevector-length bv))))) + (loop (- total n))))))) + + (fold-archive (lambda (file type content result) + (match type + ('directory + (format #t "D ~a~%" file)) + ('symlink + (format #t "S ~a -> ~a~%" file content)) + ((or 'regular 'executable) + (match content + ((input . size) + (format #t "~a ~60a ~10h B~%" + (if (eq? type 'executable) + "x" "r") + file size) + (consume-input input size)))))) + #t + port + "")) + + +;;; +;;; Entry point. +;;; + (define (guix-archive . args) (define (lines port) ;; Return lines read from PORT. @@ -353,6 +394,8 @@ the input port." (missing (remove (cut valid-path? store <>) files))) (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'list) + (list-contents (current-input-port))) ((assoc-ref opts 'extract) => (lambda (target) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 17e87f0291..ebeebd5cbe 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -25,17 +25,23 @@ #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) + #:use-module (guix progress) #:use-module (guix serialization) #:use-module (guix scripts substitute) #:use-module (rnrs bytevectors) + #:autoload (guix http-client) (http-fetch) + #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:use-module (gcrypt hash) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) + #:use-module (ice-9 ftw) #:use-module (web uri) #:export (compare-contents @@ -49,6 +55,9 @@ comparison-report-mismatch? comparison-report-inconclusive? + differing-files + call-with-mismatches + guix-challenge)) ;;; Commentary: @@ -179,20 +188,193 @@ taken since we do not import the archives." items local)))) + +;;; +;;; Reporting. +;;; + +(define dump-port* ;FIXME: deduplicate + (@@ (guix serialization) dump)) + +(define (port-sha256* port size) + ;; Like 'port-sha256', but limited to SIZE bytes. + (let-values (((out get) (open-sha256-port))) + (dump-port* port out size) + (close-port out) + (get))) + +(define (archive-contents port) + "Return a list representing the files contained in the nar read from PORT." + (fold-archive (lambda (file type contents result) + (match type + ((or 'regular 'executable) + (match contents + ((port . size) + (cons `(,file ,type ,(port-sha256* port size)) + result)))) + ('directory result) + ('symlink + (cons `(,file ,type ,contents) result)))) + '() + port + "")) + +(define (store-item-contents item) + "Return a list of files and contents for ITEM in the same format as +'archive-contents'." + (file-system-fold (const #t) ;enter? + (lambda (file stat result) ;leaf + (define short + (string-drop file (string-length item))) + + (match (stat:type stat) + ('regular + (let ((size (stat:size stat)) + (type (if (zero? (logand (stat:mode stat) + #o100)) + 'regular + 'executable))) + (cons `(,short ,type + ,(call-with-input-file file + (cut port-sha256* <> size))) + result))) + ('symlink + (cons `(,short symlink ,(readlink file)) + result)))) + (lambda (directory stat result) result) ;down + (lambda (directory stat result) result) ;up + (lambda (file stat result) result) ;skip + (lambda (file stat errno result) result) ;error + '() + item + lstat)) + +(define (call-with-nar narinfo proc) + "Call PROC with an input port from which it can read the nar pointed to by +NARINFO." + (let*-values (((uri compression size) + (narinfo-best-uri narinfo)) + ((port response) + (http-fetch uri))) + (define reporter + (progress-reporter/file (narinfo-path narinfo) size + #:abbreviation (const (uri-host uri)))) + + (define result + (call-with-decompressed-port (string->symbol compression) + (progress-report-port reporter port) + proc)) + + (close-port port) + (erase-current-line (current-output-port)) + result)) + +(define (narinfo-contents narinfo) + "Fetch the nar described by NARINFO and return a list representing the file +it contains." + (call-with-nar narinfo archive-contents)) + +(define (differing-files comparison-report) + "Return a list of files that differ among the nars and possibly the local +store item specified in COMPARISON-REPORT." + (define contents + (map narinfo-contents + (comparison-report-narinfos comparison-report))) + + (define local-contents + (and (comparison-report-local-sha256 comparison-report) + (store-item-contents (comparison-report-item comparison-report)))) + + (match (apply lset-difference equal? + (take (delete-duplicates + (if local-contents + (cons local-contents contents) + contents)) + 2)) + (((files _ ...) ...) + files))) + +(define (report-differing-files comparison-report) + "Report differences among the nars and possibly the local store item +specified in COMPARISON-REPORT." + (match (differing-files comparison-report) + (() + #t) + ((files ...) + (format #t (N_ " differing file:~%" + " differing files:~%" + (length files))) + (format #t "~{ ~a~%~}" files)))) + +(define (call-with-mismatches comparison-report proc) + "Call PROC with two directories containing the mismatching store items." + (define local-hash + (comparison-report-local-sha256 comparison-report)) + + (define narinfos + (comparison-report-narinfos comparison-report)) + + (call-with-temporary-directory + (lambda (directory1) + (call-with-temporary-directory + (lambda (directory2) + (define narinfo1 + (if local-hash + (find (lambda (narinfo) + (not (bytevector=? (narinfo-hash->sha256 + (narinfo-hash narinfo)) + local-hash))) + narinfos) + (first (comparison-report-narinfos comparison-report)))) + + (define narinfo2 + (and (not local-hash) + (find (lambda (narinfo) + (not (eq? narinfo narinfo1))) + narinfos))) + + (rmdir directory1) + (call-with-nar narinfo1 (cut restore-file <> directory1)) + (when narinfo2 + (rmdir directory2) + (call-with-nar narinfo2 (cut restore-file <> directory2))) + (proc directory1 + (if local-hash + (comparison-report-item comparison-report) + directory2))))))) + +(define %diffoscope-command + ;; Default external diff command. Pass "--exclude-directory-metadata" so + ;; that the mtime/ctime differences are ignored. + '("diffoscope" "--exclude-directory-metadata=yes")) + +(define* (report-differing-files/external comparison-report + #:optional + (command %diffoscope-command)) + "Run COMMAND to show the file-level differences for the mismatches in +COMPARISON-REPORT." + (call-with-mismatches comparison-report + (lambda (directory1 directory2) + (apply system* + (append command + (list directory1 directory2)))))) + (define* (summarize-report comparison-report #:key + (report-differences (const #f)) (hash->string bytevector->nix-base32-string) verbose?) - "Write to the current error port a summary of REPORT, a <comparison-report> -object. When VERBOSE?, display matches in addition to mismatches and -inconclusive reports." + "Write to the current error port a summary of COMPARISON-REPORT, a +<comparison-report> object. When VERBOSE?, display matches in addition to +mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES +with COMPARISON-REPORT." (define (report-hashes item local narinfos) (if local (report (G_ " local hash: ~a~%") (hash->string local)) (report (G_ " no local build for '~a'~%") item)) (for-each (lambda (narinfo) (report (G_ " ~50a: ~a~%") - (uri->string (first (narinfo-uris narinfo))) + (uri->string (narinfo-best-uri narinfo)) (hash->string (narinfo-hash->sha256 (narinfo-hash narinfo))))) narinfos)) @@ -200,7 +382,8 @@ inconclusive reports." (match comparison-report (($ <comparison-report> item 'mismatch local (narinfos ...)) (report (G_ "~a contents differ:~%") item) - (report-hashes item local narinfos)) + (report-hashes item local narinfos) + (report-differences comparison-report)) (($ <comparison-report> item 'inconclusive #f narinfos) (warning (G_ "could not challenge '~a': no local build~%") item)) (($ <comparison-report> item 'inconclusive locals ()) @@ -237,6 +420,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) compare build results with those at URLS")) (display (G_ " -v, --verbose show details about successful comparisons")) + (display (G_ " + --diff=MODE show differences according to MODE")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -254,6 +439,22 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (lambda args (show-version-and-exit "guix challenge"))) + (option '("diff") #t #f + (lambda (opt name arg result . rest) + (define mode + (match arg + ("none" (const #t)) + ("simple" report-differing-files) + ("diffoscope" report-differing-files/external) + ((and (? (cut string-prefix? "/" <>)) command) + (cute report-differing-files/external <> + (string-tokenize command))) + (_ (leave (G_ "~a: unknown diff mode~%") arg)))) + + (apply values + (alist-cons 'difference-report mode result) + rest))) + (option '("substitute-urls") #t #f (lambda (opt name arg result . rest) (apply values @@ -269,7 +470,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (define %default-options `((system . ,(%current-system)) - (substitute-urls . ,%default-substitute-urls))) + (substitute-urls . ,%default-substitute-urls) + (difference-report . ,report-differing-files))) ;;; @@ -286,12 +488,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) opts)) (system (assoc-ref opts 'system)) (urls (assoc-ref opts 'substitute-urls)) + (diff (assoc-ref opts 'difference-report)) (verbose? (assoc-ref opts 'verbose?))) (leave-on-EPIPE (with-store store ;; Disable grafts since substitute servers normally provide only ;; ungrafted stuff. - (parameterize ((%graft? #f)) + (parameterize ((%graft? #f) + (current-terminal-columns (terminal-columns))) (let ((files (match files (() (filter (cut locally-built? store <>) @@ -305,7 +509,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (mlet* %store-monad ((items (mapm %store-monad ensure-store-item files)) (reports (compare-contents items urls))) - (for-each (cut summarize-report <> #:verbose? verbose?) + (for-each (cut summarize-report <> #:verbose? verbose? + #:report-differences diff) reports) (report "\n") (summarize-report-list reports) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index bbacc93bc0..b84e37cbf2 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -319,7 +319,7 @@ to the search paths of PROFILE." entry-point localstatedir? (symlinks '()) - (archiver squashfs-tools-next)) + (archiver squashfs-tools)) "Return a squashfs image containing a store initialized with the closure of PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount points for virtual file systems (like procfs), and optional symlinks. @@ -753,11 +753,6 @@ last resort for relocation." (manifest-entry-output entry) args)))) -(define (map-manifest-entries proc manifest) - "Apply PROC to all the entries of MANIFEST and return a new manifest." - (make-manifest - (map proc (manifest-entries manifest)))) - ;;; ;;; Command-line options. @@ -979,36 +974,32 @@ Create a bundle of PACKAGE.\n")) (('manifest . file) file) (_ #f)) opts))) - (define properties + (define with-provenance (if (assoc-ref opts 'save-provenance?) - (lambda (package) - (match (package-provenance package) - (#f - (warning (G_ "could not determine provenance of package ~a~%") - (package-full-name package)) - '()) - (sexp - `((provenance . ,sexp))))) - (const '()))) - - (cond - ((and (not (null? manifests)) (not (null? packages))) - (leave (G_ "both a manifest and a package list were given~%"))) - ((not (null? manifests)) - (concatenate-manifests - (map (lambda (file) - (let ((user-module (make-user-module - '((guix profiles) (gnu))))) - (load* file user-module))) - manifests))) - (else - (manifest - (map (match-lambda - ((package output) - (package->manifest-entry package output - #:properties - (properties package)))) - packages)))))) + (lambda (manifest) + (map-manifest-entries + (lambda (entry) + (let ((entry (manifest-entry-with-provenance entry))) + (unless (assq 'provenance (manifest-entry-properties entry)) + (warning (G_ "could not determine provenance of package ~a~%") + (manifest-entry-name entry))) + entry)) + manifest)) + identity)) + + (with-provenance + (cond + ((and (not (null? manifests)) (not (null? packages))) + (leave (G_ "both a manifest and a package list were given~%"))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) + (else + (packages->manifest packages)))))) (with-error-handling (with-store store @@ -1045,7 +1036,7 @@ Create a bundle of PACKAGE.\n")) bootstrap-xz (assoc-ref opts 'compressor))) (archiver (if (equal? pack-format 'squashfs) - squashfs-tools-next + squashfs-tools (if bootstrap? %bootstrap-coreutils&co tar))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 92c6e34194..ea16435d2d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -38,7 +38,7 @@ #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) - #:autoload (guix describe) (package-provenance) + #:use-module (guix describe) #:autoload (guix store roots) (gc-roots) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) @@ -883,7 +883,10 @@ processed, #f otherwise." opts)) (manifest (match files (() (profile-manifest profile)) - (_ (concatenate-manifests (map load-manifest files))))) + (_ (map-manifest-entries + manifest-entry-with-provenance + (concatenate-manifests + (map load-manifest files)))))) (step1 (options->removable opts manifest (manifest-transaction))) (step2 (options->installable opts manifest step1)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b6034a75d2..7eca2c6874 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -80,6 +80,7 @@ narinfo-signature narinfo-hash->sha256 + narinfo-best-uri lookup-narinfos lookup-narinfos/diverse @@ -822,35 +823,6 @@ was found." (= (string-length file) 32))))) (narinfo-cache-directories directory))) -(define (progress-report-port reporter port) - "Return a port that continuously reports the bytes read from PORT using -REPORTER, which should be a <progress-reporter> object." - (match reporter - (($ <progress-reporter> start report stop) - (let* ((total 0) - (read! (lambda (bv start count) - (let ((n (match (get-bytevector-n! port bv start count) - ((? eof-object?) 0) - (x x)))) - (set! total (+ total n)) - (report total) - n)))) - (start) - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (lambda () - ;; XXX: Kludge! When used through - ;; 'decompressed-port', this port ends - ;; up being closed twice: once in a - ;; child process early on, and at the - ;; end in the parent process. Ignore - ;; the early close so we don't output - ;; a spurious "download-succeeded" - ;; trace. - (unless (zero? total) - (stop)) - (close-port port))))))) - (define-syntax with-networking (syntax-rules () "Catch DNS lookup errors and TLS errors and gracefully exit." @@ -913,7 +885,7 @@ expected by the daemon." (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) (narinfo-references narinfo)) - (let-values (((uri compression file-size) (select-uri narinfo))) + (let-values (((uri compression file-size) (narinfo-best-uri narinfo))) (format #t "~a\n~a\n" (or file-size 0) (or (narinfo-size narinfo) 0)))) @@ -967,7 +939,7 @@ this is a rough approximation." (_ (or (string=? compression2 "none") (string=? compression2 "gzip"))))) -(define (select-uri narinfo) +(define (narinfo-best-uri narinfo) "Select the \"best\" URI to download NARINFO's nar, and return three values: the URI, its compression method (a string), and the compressed file size." (define choices @@ -1008,7 +980,7 @@ DESTINATION as a nar file. Verify the substitute against ACL." store-item)) (let-values (((uri compression file-size) - (select-uri narinfo))) + (narinfo-best-uri narinfo))) ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3e9570753d..e69a3b6c97 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1189,6 +1189,11 @@ resulting from command-line parsing." (define (process-command command args opts) "Process COMMAND, one of the 'guix system' sub-commands. ARGS is its argument list and OPTS is the option alist." + (define-syntax-rule (with-store* store exp ...) + (with-store store + (set-build-options-from-command-line store opts) + exp ...)) + (case command ;; The following commands do not need to use the store, and they do not need ;; an operating system configuration file. @@ -1213,22 +1218,20 @@ argument list and OPTS is the option alist." (() #f) ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) - (with-store store + (with-store* store (delete-matching-generations store %system-profile pattern) (reinstall-bootloader store (generation-number %system-profile))))) ((switch-generation) (let ((pattern (match args ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) - (with-store store - (set-build-options-from-command-line store opts) + (with-store* store (switch-to-system-generation store pattern)))) ((roll-back) (let ((pattern (match args (() "") (x (leave (G_ "wrong number of arguments~%")))))) - (with-store store - (set-build-options-from-command-line store opts) + (with-store* store (roll-back-system store)))) ;; The following commands need to use the store, and they also ;; need an operating system configuration file. @@ -1297,6 +1300,7 @@ argument list and OPTS is the option alist." ;;; Local Variables: ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) +;;; eval: (put 'with-store* 'scheme-indent-function 1) ;;; End: ;;; system.scm ends here |