diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 518 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/install.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 60 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 28 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 51 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 106 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/upgrade.scm | 3 |
13 files changed, 230 insertions, 591 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index e59e0ee67f..e9de97c881 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -31,11 +31,6 @@ #:use-module (guix utils) - ;; Use the procedure that destructures "NAME-VERSION" forms. - #:use-module ((guix build utils) - #:select ((package-name->name+version - . hyphen-package-name->name+version))) - #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix profiles) @@ -45,28 +40,22 @@ #:use-module (ice-9 match) #:use-module (ice-9 vlist) #: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-35) #:use-module (srfi srfi-37) #:use-module (gnu packages) - #:autoload (guix download) (download-to-store) - #:autoload (guix git-download) (git-reference? git-reference-url) - #:autoload (guix git) (git-checkout git-checkout? git-checkout-url) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) + #:use-module (guix transformations) #:export (%standard-build-options set-build-options-from-command-line set-build-options-from-command-line* show-build-options-help - %transformation-options - options->transformation - manifest-entry-with-transformations - show-transformation-options-help - guix-build register-root register-root*)) @@ -151,493 +140,6 @@ found. Return #f if no build log was found." (define register-root* (store-lift register-root)) -(define (numeric-extension? file-name) - "Return true if FILE-NAME ends with digits." - (string-every char-set:hex-digit (file-extension file-name))) - -(define (tarball-base-name file-name) - "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar -extensions." - ;; TODO: Factorize. - (cond ((not (file-extension file-name)) - file-name) - ((numeric-extension? file-name) - file-name) - ((string=? (file-extension file-name) "tar") - (file-sans-extension file-name)) - ((file-extension file-name) - => - (match-lambda - ("scm" file-name) - (else (tarball-base-name (file-sans-extension file-name))))) - (else - file-name))) - -(define* (package-with-source store p uri #:optional version) - "Return a package based on P but with its source taken from URI. Extract -the new package's version number from URI." - (let ((base (tarball-base-name (basename uri)))) - (let-values (((_ version*) - (hyphen-package-name->name+version base))) - (package (inherit p) - (version (or version version* - (package-version p))) - - ;; Use #:recursive? #t to allow for directories. - (source (download-to-store store uri - #:recursive? #t)) - - ;; Override the replacement, otherwise '--with-source' would - ;; have no effect. - (replacement #f))))) - - -;;; -;;; Transformations. -;;; - -(define (transform-package-source sources) - "Return a transformation procedure that replaces package sources with the -matching URIs given in SOURCES." - (define new-sources - (map (lambda (uri) - (match (string-index uri #\=) - (#f - ;; Determine the package name and version from URI. - (call-with-values - (lambda () - (hyphen-package-name->name+version - (tarball-base-name (basename uri)))) - (lambda (name version) - (list name version uri)))) - (index - ;; What's before INDEX is a "PKG@VER" or "PKG" spec. - (call-with-values - (lambda () - (package-name->name+version (string-take uri index))) - (lambda (name version) - (list name version - (string-drop uri (+ 1 index)))))))) - sources)) - - (lambda (store obj) - (let loop ((sources new-sources) - (result '())) - (match obj - ((? package? p) - (match (assoc-ref sources (package-name p)) - ((version source) - (package-with-source store p source version)) - (#f - p))) - (_ - obj))))) - -(define (evaluate-replacement-specs specs proc) - "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list -of package spec/procedure pairs as expected by 'package-input-rewriting/spec'. -PROC is called with the package to be replaced and its replacement according -to SPECS. Raise an error if an element of SPECS uses invalid syntax, or if a -package it refers to could not be found." - (define not-equal - (char-set-complement (char-set #\=))) - - (map (lambda (spec) - (match (string-tokenize spec not-equal) - ((spec new) - (cons spec - (let ((new (specification->package new))) - (lambda (old) - (proc old new))))) - (x - (leave (G_ "invalid replacement specification: ~s~%") spec)))) - specs)) - -(define (transform-package-inputs replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"guile=guile@2.1\" meaning that, any dependency on a package -called \"guile\" must be replaced with a dependency on a version 2.1 of -\"guile\"." - (let* ((replacements (evaluate-replacement-specs replacement-specs - (lambda (old new) - new))) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define (transform-package-inputs/graft replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the -current 'gnutls' package, after which version 3.5.4 is grafted onto them." - (define (set-replacement old new) - (package (inherit old) (replacement new))) - - (let* ((replacements (evaluate-replacement-specs replacement-specs - set-replacement)) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define %not-equal - (char-set-complement (char-set #\=))) - -(define (package-git-url package) - "Return the URL of the Git repository for package, or raise an error if -the source of PACKAGE is not fetched from a Git repository." - (let ((source (package-source package))) - (cond ((and (origin? source) - (git-reference? (origin-uri source))) - (git-reference-url (origin-uri source))) - ((git-checkout? source) - (git-checkout-url source)) - (else - (leave (G_ "the source of ~a is not a Git reference~%") - (package-full-name package)))))) - -(define (evaluate-git-replacement-specs specs proc) - "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list -of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the -replacement package. Raise an error if an element of SPECS uses invalid -syntax, or if a package it refers to could not be found." - (map (lambda (spec) - (match (string-tokenize spec %not-equal) - ((spec branch-or-commit) - (define (replace old) - (let* ((source (package-source old)) - (url (package-git-url old))) - (proc old url branch-or-commit))) - - (cons spec replace)) - (x - (leave (G_ "invalid replacement specification: ~s~%") spec)))) - specs)) - -(define (transform-package-source-branch replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"guile-next=stable-3.0\" meaning that packages are built using -'guile-next' from the latest commit on its 'stable-3.0' branch." - (define (replace old url branch) - (package - (inherit old) - (version (string-append "git." (string-map (match-lambda - (#\/ #\-) - (chr chr)) - branch))) - (source (git-checkout (url url) (branch branch) - (recursive? #t))))) - - (let* ((replacements (evaluate-git-replacement-specs replacement-specs - replace)) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define (transform-package-source-commit replacement-specs) - "Return a procedure that, when passed a package, replaces its direct -dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of -strings like \"guile-next=cabba9e\" meaning that packages are built using -'guile-next' from commit 'cabba9e'." - (define (replace old url commit) - (package - (inherit old) - (version (if (and (> (string-length commit) 1) - (string-prefix? "v" commit) - (char-set-contains? char-set:digit - (string-ref commit 1))) - (string-drop commit 1) ;looks like a tag like "v1.0" - (string-append "git." - (if (< (string-length commit) 7) - commit - (string-take commit 7))))) - (source (git-checkout (url url) (commit commit) - (recursive? #t))))) - - (let* ((replacements (evaluate-git-replacement-specs replacement-specs - replace)) - (rewrite (package-input-rewriting/spec replacements))) - (lambda (store obj) - (if (package? obj) - (rewrite obj) - obj)))) - -(define (transform-package-source-git-url replacement-specs) - "Return a procedure that, when passed a package, replaces its dependencies -according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like -\"guile-json=https://gitthing.com/…\" meaning that packages are built using -a checkout of the Git repository at the given URL." - (define replacements - (map (lambda (spec) - (match (string-tokenize spec %not-equal) - ((spec url) - (cons spec - (lambda (old) - (package - (inherit old) - (source (git-checkout (url url) - (recursive? #t))))))) - (_ - (leave (G_ "~a: invalid Git URL replacement specification~%") - spec)))) - replacement-specs)) - - (define rewrite - (package-input-rewriting/spec replacements)) - - (lambda (store obj) - (if (package? obj) - (rewrite obj) - obj))) - -(define (package-dependents/spec top bottom) - "Return the list of dependents of BOTTOM, a spec string, that are also -dependencies of TOP, a package." - (define-values (name version) - (package-name->name+version bottom)) - - (define dependent? - (mlambda (p) - (and (package? p) - (or (and (string=? name (package-name p)) - (or (not version) - (version-prefix? version (package-version p)))) - (match (bag-direct-inputs (package->bag p)) - (((labels dependencies . _) ...) - (any dependent? dependencies))))))) - - (filter dependent? (package-closure (list top)))) - -(define (package-toolchain-rewriting p bottom toolchain) - "Return a procedure that, when passed a package that's either BOTTOM or one -of its dependents up to P so, changes it so it is built with TOOLCHAIN. -TOOLCHAIN must be an input list." - (define rewriting-property - (gensym " package-toolchain-rewriting")) - - (match (package-dependents/spec p bottom) - (() ;P does not depend on BOTTOM - identity) - (set - ;; SET is the list of packages "between" P and BOTTOM (included) whose - ;; toolchain needs to be changed. - (package-mapping (lambda (p) - (if (or (assq rewriting-property - (package-properties p)) - (not (memq p set))) - p - (let ((p (package-with-c-toolchain p toolchain))) - (package/inherit p - (properties `((,rewriting-property . #t) - ,@(package-properties p))))))) - (lambda (p) - (or (assq rewriting-property (package-properties p)) - (not (memq p set)))) - #:deep? #t)))) - -(define (transform-package-toolchain replacement-specs) - "Return a procedure that, when passed a package, changes its toolchain or -that of its dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is -a list of strings like \"fftw=gcc-toolchain@10\" meaning that the package to -the left of the equal sign must be built with the toolchain to the right of -the equal sign." - (define split-on-commas - (cute string-tokenize <> (char-set-complement (char-set #\,)))) - - (define (specification->input spec) - (let ((package (specification->package spec))) - (list (package-name package) package))) - - (define replacements - (map (lambda (spec) - (match (string-tokenize spec %not-equal) - ((spec (= split-on-commas toolchain)) - (cons spec (map specification->input toolchain))) - (_ - (leave (G_ "~a: invalid toolchain replacement specification~%") - spec)))) - replacement-specs)) - - (lambda (store obj) - (if (package? obj) - (or (any (match-lambda - ((bottom . toolchain) - ((package-toolchain-rewriting obj bottom toolchain) obj))) - replacements) - obj) - obj))) - -(define (transform-package-tests specs) - "Return a procedure that, when passed a package, sets #:tests? #f in its -'arguments' field." - (define (package-without-tests p) - (package/inherit p - (arguments - (substitute-keyword-arguments (package-arguments p) - ((#:tests? _ #f) #f))))) - - (define rewrite - (package-input-rewriting/spec (map (lambda (spec) - (cons spec package-without-tests)) - specs))) - - (lambda (store obj) - (if (package? obj) - (rewrite obj) - obj))) - -(define %transformations - ;; Transformations that can be applied to things to build. The car is the - ;; key used in the option alist, and the cdr is the transformation - ;; procedure; it is called with two arguments: the store, and a list of - ;; things to build. - `((with-source . ,transform-package-source) - (with-input . ,transform-package-inputs) - (with-graft . ,transform-package-inputs/graft) - (with-branch . ,transform-package-source-branch) - (with-commit . ,transform-package-source-commit) - (with-git-url . ,transform-package-source-git-url) - (with-c-toolchain . ,transform-package-toolchain) - (without-tests . ,transform-package-tests))) - -(define (transformation-procedure key) - "Return the transformation procedure associated with KEY, a symbol such as -'with-source', or #f if there is none." - (any (match-lambda - ((k . proc) - (and (eq? k key) proc))) - %transformations)) - -(define %transformation-options - ;; The command-line interface to the above transformations. - (let ((parser (lambda (symbol) - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest))))) - (list (option '("with-source") #t #f - (parser 'with-source)) - (option '("with-input") #t #f - (parser 'with-input)) - (option '("with-graft") #t #f - (parser 'with-graft)) - (option '("with-branch") #t #f - (parser 'with-branch)) - (option '("with-commit") #t #f - (parser 'with-commit)) - (option '("with-git-url") #t #f - (parser 'with-git-url)) - (option '("with-c-toolchain") #t #f - (parser 'with-c-toolchain)) - (option '("without-tests") #t #f - (parser 'without-tests))))) - -(define (show-transformation-options-help) - (display (G_ " - --with-source=[PACKAGE=]SOURCE - use SOURCE when building the corresponding package")) - (display (G_ " - --with-input=PACKAGE=REPLACEMENT - replace dependency PACKAGE by REPLACEMENT")) - (display (G_ " - --with-graft=PACKAGE=REPLACEMENT - graft REPLACEMENT on packages that refer to PACKAGE")) - (display (G_ " - --with-branch=PACKAGE=BRANCH - build PACKAGE from the latest commit of BRANCH")) - (display (G_ " - --with-commit=PACKAGE=COMMIT - build PACKAGE from COMMIT")) - (display (G_ " - --with-git-url=PACKAGE=URL - build PACKAGE from the repository at URL")) - (display (G_ " - --with-c-toolchain=PACKAGE=TOOLCHAIN - build PACKAGE and its dependents with TOOLCHAIN")) - (display (G_ " - --without-tests=PACKAGE - build PACKAGE without running its tests"))) - - -(define (options->transformation opts) - "Return a procedure that, when passed an object to build (package, -derivation, etc.), applies the transformations specified by OPTS." - (define applicable - ;; List of applicable transformations as symbol/procedure pairs in the - ;; order in which they appear on the command line. - (filter-map (match-lambda - ((key . value) - (match (transformation-procedure key) - (#f - #f) - (transform - ;; XXX: We used to pass TRANSFORM a list of several - ;; arguments, but we now pass only one, assuming that - ;; transform composes well. - (list key value (transform (list value))))))) - (reverse opts))) - - (define (package-with-transformation-properties p) - (package/inherit p - (properties `((transformations - . ,(map (match-lambda - ((key value _) - (cons key value))) - applicable)) - ,@(package-properties p))))) - - (lambda (store obj) - (define (tagged-object new) - (if (and (not (eq? obj new)) - (package? new) (not (null? applicable))) - (package-with-transformation-properties new) - new)) - - (tagged-object - (fold (match-lambda* - (((name value transform) obj) - (let ((new (transform store obj))) - (when (eq? new obj) - (warning (G_ "transformation '~a' had no effect on ~a~%") - name - (if (package? obj) - (package-full-name obj) - obj))) - new))) - obj - applicable)))) - -(define (package-transformations package) - "Return the transformations applied to PACKAGE according to its properties." - (match (assq-ref (package-properties package) 'transformations) - (#f '()) - (transformations transformations))) - -(define (manifest-entry-with-transformations entry) - "Return ENTRY with an additional 'transformations' property if it's not -already there." - (let ((properties (manifest-entry-properties entry))) - (if (assq 'transformations properties) - entry - (let ((item (manifest-entry-item entry))) - (manifest-entry - (inherit entry) - (properties - (match (and (package? item) - (package-transformations item)) - ((or #f '()) - properties) - (transformations - `((transformations . ,transformations) - ,@properties))))))))) - ;;; ;;; Standard command-line build options. @@ -678,6 +180,8 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " -M, --max-jobs=N allow at most N build jobs")) (display (G_ " + --help-transform list package transformation options not shown here")) + (display (G_ " --debug=LEVEL produce debugging output at LEVEL"))) (define (set-build-options-from-command-line store opts) @@ -813,7 +317,14 @@ use '--no-offload' instead~%"))) (if c (apply values (alist-cons 'max-jobs c result) rest) (leave (G_ "not a number: '~a' option argument: ~a~%") - name arg))))))) + name arg))))) + (option '("help-transform") #f #f + (lambda _ + (format #t + (G_ "Available package transformation options:~%")) + (show-transformation-options-help) + (newline) + (exit 0))))) ;;; @@ -870,8 +381,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (newline) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -1053,8 +562,7 @@ build." (systems systems))) (define things-to-build - (map (cut transform store <>) - (options->things-to-build opts))) + (map transform (options->things-to-build opts))) (define (compute-derivation obj system) ;; Compute the derivation of OBJ for SYSTEM. diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 085f11a9d4..2328df98b8 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -32,6 +32,7 @@ #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (gnu build linux-container) #:use-module (gnu build accounts) #:use-module ((guix build syscalls) #:select (set-network-interface-up)) @@ -179,8 +180,6 @@ COMMAND or an interactive shell in that environment.\n")) (newline) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -322,7 +321,7 @@ for the corresponding packages." (manifest-entry-output e2)))) (define transform - (cut (options->transformation opts) store <>)) + (options->transformation opts)) (define* (package->manifest-entry* package #:optional (output "out")) (package->manifest-entry (transform package) output)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index d7a08a4fe1..6874904deb 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -34,11 +34,11 @@ #:use-module (guix sets) #:use-module ((guix diagnostics) #:select (location-file formatted-message)) - #:use-module ((guix scripts build) - #:select (show-transformation-options-help - options->transformation - %standard-build-options + #:use-module ((guix transformations) + #:select (options->transformation %transformation-options)) + #:use-module ((guix scripts build) + #:select (%standard-build-options)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -546,8 +546,6 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -585,11 +583,11 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (('argument . (? store-path? item)) item) (('argument . spec) - (transform store - (specification->package spec))) + (transform + (specification->package spec))) (('expression . exp) - (transform store - (read/eval-package-expression exp))) + (transform + (read/eval-package-expression exp))) (_ #f)) opts))) (run-with-store store diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm index 894e60f9da..82f5875dd1 100644 --- a/guix/scripts/install.scm +++ b/guix/scripts/install.scm @@ -20,6 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts package) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -38,8 +39,6 @@ This is an alias for 'guix package -i'.\n")) (newline) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 979d4f8363..18cd167537 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -9,7 +9,7 @@ ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> -;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2019, 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -98,6 +98,12 @@ run the checkers on all packages.\n")) (display (G_ " -c, --checkers=CHECKER1,CHECKER2... only run the specified checkers")) + (display (G_ " + -x, --exclude=CHECKER1,CHECKER2... + exclude the specified checkers")) + (display (G_ " + -n, --no-network only run checkers that do not access the network")) + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) (newline) @@ -110,32 +116,37 @@ run the checkers on all packages.\n")) (newline) (show-bug-report-information)) +(define (option-checker short-long) + ;; Factorize the creation of the two options -c/--checkers and -x/--exclude, + ;; see %options. The parameter SHORT-LONG is the list containing the short + ;; and long name. The alist uses the long name as symbol. + (option short-long #t #f + (lambda (opt name arg result) + (let ((names (map string->symbol (string-split arg #\,))) + (checker-names (map lint-checker-name %all-checkers)) + (option-name (string->symbol (match short-long + ((short long) long))))) + (for-each (lambda (c) + (unless (memq c checker-names) + (leave (G_ "~a: invalid checker~%") c))) + names) + (alist-cons option-name + (filter (lambda (checker) + (member (lint-checker-name checker) + names)) + %all-checkers) + result))))) (define %options ;; Specification of the command-line options. ;; TODO: add some options: ;; * --certainty=[low,medium,high]: only run checkers that have at least this ;; 'certainty'. - (list (option '(#\c "checkers") #t #f - (lambda (opt name arg result) - (let ((names (map string->symbol (string-split arg #\,))) - (checker-names (map lint-checker-name %all-checkers))) - (for-each (lambda (c) - (unless (memq c checker-names) - (leave (G_ "~a: invalid checker~%") c))) - names) - (alist-cons 'checkers - (filter (lambda (checker) - (member (lint-checker-name checker) - names)) - %all-checkers) - result)))) + (list (option-checker '(#\c "checkers")) + (option-checker '(#\x "exclude")) (option '(#\n "no-network") #f #f (lambda (opt name arg result) - (alist-cons 'checkers - %local-checkers - (alist-delete 'checkers - result)))) + (alist-cons 'no-network? #t result))) (find (lambda (option) (member "load-path" (option-names option))) %standard-build-options) @@ -172,7 +183,16 @@ run the checkers on all packages.\n")) value) (_ #f)) (reverse opts))) - (checkers (or (assoc-ref opts 'checkers) %all-checkers))) + (no-checkers (or (assoc-ref opts 'exclude) '())) + (the-checkers (filter (lambda (checker) + (not (member checker no-checkers))) + (or (assoc-ref opts 'checkers) %all-checkers))) + (checkers + (if (assoc-ref opts 'no-network?) + (filter (lambda (checker) + (member checker %local-checkers)) + the-checkers) + the-checkers))) (when (assoc-ref opts 'list?) (list-checkers-and-exit checkers)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index a5fe98b675..6366556647 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -53,7 +53,22 @@ #:use-module (ice-9 format) #:use-module (ice-9 binary-ports) #:export (build-machine + build-machine? + build-machine-name + build-machine-port + build-machine-systems + build-machine-user + build-machine-private-key + build-machine-host-key + build-machine-compression + build-machine-daemon-socket + build-machine-overload-threshold + build-machine-systems + build-machine-features + build-requirements + build-requirements? + guix-offload)) ;;; Commentary: @@ -182,8 +197,10 @@ can interpret meaningfully." private key from '~a': ~a") file str))))) -(define* (open-ssh-session machine #:optional (max-silent-time -1)) - "Open an SSH session for MACHINE and return it. Throw an error on failure." +(define* (open-ssh-session machine #:optional max-silent-time) + "Open an SSH session for MACHINE and return it. Throw an error on failure. +When MAX-SILENT-TIME is true, it must be a positive integer denoting the +number of seconds after which the connection times out." (let ((private (private-key-from-file* (build-machine-private-key machine))) (public (public-key-from-file (string-append (build-machine-private-key machine) @@ -220,9 +237,10 @@ private key from '~a': ~a") (leave (G_ "SSH public key authentication failed for '~a': ~a~%") (build-machine-name machine) (get-error session)))) - ;; From then on use MAX-SILENT-TIME as the absolute timeout when - ;; reading from or write to a channel for this session. - (session-set! session 'timeout max-silent-time) + (when max-silent-time + ;; From then on use MAX-SILENT-TIME as the absolute timeout when + ;; reading from or write to a channel for this session. + (session-set! session 'timeout max-silent-time)) session) (x diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 0b66da01f9..06509ace2d 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +43,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -135,9 +137,11 @@ dependencies are registered." (define build (with-extensions gcrypt-sqlite3&co - (with-imported-modules (source-module-closure - '((guix build store-copy) - (guix store database))) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + '((guix build store-copy) + (guix store database)) + #:select? not-config?)) #~(begin (use-modules (guix store database) (guix build store-copy) @@ -748,12 +752,13 @@ last resort for relocation." (guix elf))) #~(begin (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) + ((guix build union) #:select (symlink-relative)) (guix elf) (guix build gremlin) (ice-9 binary-ports) (ice-9 ftw) (ice-9 match) + (ice-9 receive) (srfi srfi-1) (rnrs bytevectors)) @@ -847,7 +852,7 @@ last resort for relocation." (("@STORE_DIRECTORY@") (%store-directory))) (let* ((base (strip-store-prefix program)) - (result (string-append target "/" base)) + (result (string-append target base)) (proot #$(and proot? #~(string-drop #$(file-append (proot) "/bin/proot") @@ -856,6 +861,9 @@ last resort for relocation." (mkdir-p (dirname result)) (apply invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" "run.c" "-o" result + (string-append "-DWRAPPER_PROGRAM=\"" + (canonicalize-path (dirname result)) "/" + (basename result) "\"") (append (if proot (list (string-append "-DPROOT_PROGRAM=\"" proot "\"")) @@ -870,16 +878,27 @@ last resort for relocation." (mkdir target) (for-each (lambda (file) (unless (member file '("." ".." "bin" "sbin" "libexec")) - (let ((file* (string-append input "/" file))) - (symlink (relative-file-name target file*) - (string-append target "/" file))))) + (symlink-relative (string-append input "/" file) + (string-append target "/" file)))) (scandir input)) - (for-each build-wrapper - ;; Note: Trailing slash in case these are symlinks. - (append (find-files (string-append input "/bin/")) - (find-files (string-append input "/sbin/")) - (find-files (string-append input "/libexec/"))))))) + (receive (executables others) + (partition executable-file? + ;; Note: Trailing slash in case these are symlinks. + (append (find-files (string-append input "/bin/")) + (find-files (string-append input "/sbin/")) + (find-files (string-append input "/libexec/")))) + ;; Wrap only executables, since the wrapper will eventually need + ;; to execve them. E.g. git's "libexec" directory contains many + ;; shell scripts that are source'd from elsewhere, which fails if + ;; they are wrapped. + (for-each build-wrapper executables) + ;; Link any other non-executable files + (for-each (lambda (old) + (let ((new (string-append target (strip-store-prefix old)))) + (mkdir-p (dirname new)) + (symlink-relative old new))) + others))))) (computed-file (string-append (cond ((package? package) @@ -1043,8 +1062,6 @@ last resort for relocation." Create a bundle of PACKAGE.\n")) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " @@ -1118,9 +1135,9 @@ Create a bundle of PACKAGE.\n")) (let* ((transform (options->transformation opts)) (packages (map (match-lambda (((? package? package) output) - (list (transform store package) output)) + (list (transform package) output)) ((? package? package) - (list (transform store package) "out"))) + (list (transform package) "out"))) (reverse (filter-map maybe-package-argument opts)))) (manifests (filter-map (match-lambda diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 2f04652634..eb2e67a0de 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -41,6 +41,7 @@ #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix describe) #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) @@ -223,7 +224,7 @@ non-zero relevance score." (($ <manifest-entry> name version output (? string? path)) (match (find-best-packages-by-name name #f) ((pkg . rest) - (let* ((pkg (transform store pkg)) + (let* ((pkg (transform pkg)) (candidate-version (package-version pkg))) (match (package-superseded pkg) ((? package? new) @@ -397,8 +398,6 @@ Install, remove, or upgrade packages in a single transaction.\n")) (newline) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -873,7 +872,7 @@ processed, #f otherwise." (define transform (options->transformation opts)) (define (transform-entry entry) - (let ((item (transform store (manifest-entry-item entry)))) + (let ((item (transform (manifest-entry-item entry)))) (manifest-entry-with-transformations (manifest-entry (inherit entry) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 4eaf961ab2..e8faf379e2 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2020 by Amar M. Singh <nly@disroot.org> ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -82,6 +83,9 @@ Publish ~a over HTTP.\n") %store-directory) (display (G_ " -c, --cache=DIRECTORY cache published items to DIRECTORY")) (display (G_ " + --cache-bypass-threshold=SIZE + serve store items below SIZE even when not cached")) + (display (G_ " --workers=N use N workers to bake items")) (display (G_ " --ttl=TTL announce narinfos can be cached for TTL seconds")) @@ -134,6 +138,12 @@ if ITEM is already compressed." (list %no-compression) requested)) +(define (low-compression c) + "Return <compression> of the same type as C, but optimized for low CPU +usage." + (compression (compression-type c) + (min (compression-level c) 2))) + (define %options (list (option '(#\h "help") #f #f (lambda _ @@ -184,6 +194,10 @@ if ITEM is already compressed." (option '(#\c "cache") #t #f (lambda (opt name arg result) (alist-cons 'cache arg result))) + (option '("cache-bypass-threshold") #t #f + (lambda (opt name arg result) + (alist-cons 'cache-bypass-threshold (size->number arg) + result))) (option '("workers") #t #f (lambda (opt name arg result) (alist-cons 'workers (string->number* arg) @@ -434,7 +448,7 @@ items. Failing that, we could eventually have to recompute them and return (expiration-time file)))))) (define (hash-part->path* store hash cache) - "Like 'hash-part->path' but cached results under CACHE. This ensures we can + "Like 'hash-part->path' but cache results under CACHE. This ensures we can still map HASH to the corresponding store file name, even if said store item vanished from the store in the meantime." (let ((cached (hash-part-mapping-cache-file cache hash))) @@ -454,6 +468,18 @@ vanished from the store in the meantime." result)) (apply throw args)))))) +(define cache-bypass-threshold + ;; Maximum size of a store item that may be served by the '/cached' handlers + ;; below even when not in cache. + (make-parameter (* 10 (expt 2 20)))) + +(define (bypass-cache? store item) + "Return true if we allow ITEM to be downloaded before it is cached. ITEM is +interpreted as the basename of a store item." + (guard (c ((store-error? c) #f)) + (< (path-info-nar-size (query-path-info store item)) + (cache-bypass-threshold)))) + (define* (render-narinfo/cached store request hash #:key ttl (compressions (list %no-compression)) (nar-path "nar") @@ -513,9 +539,20 @@ requested using POOL." (nar-expiration-time ttl) #:delete-entry delete-entry #:cleanup-period ttl)))) - (not-found request - #:phrase "We're baking it" - #:ttl 300)) ;should be available within 5m + + ;; If ITEM passes 'bypass-cache?', render a temporary narinfo right + ;; away, with a short TTL. The narinfo is temporary because it + ;; lacks 'FileSize', for instance, which the cached narinfo will + ;; have. Chances are that the nar will be baked by the time the + ;; client asks for it. + (if (bypass-cache? store item) + (render-narinfo store request hash + #:ttl 300 ;temporary + #:nar-path nar-path + #:compressions compressions) + (not-found request + #:phrase "We're baking it" + #:ttl 300))) ;should be available within 5m (else (not-found request #:phrase ""))))) @@ -627,19 +664,32 @@ return it; otherwise, return 404. When TTL is true, use it as the 'Cache-Control' expiration time." (let ((cached (nar-cache-file cache store-item #:compression compression))) - (if (file-exists? cached) - (values `((content-type . (application/octet-stream - (charset . "ISO-8859-1"))) - ,@(if ttl - `((cache-control (max-age . ,ttl))) - '()) - - ;; XXX: We're not returning the actual contents, deferring - ;; instead to 'http-write'. This is a hack to work around - ;; <http://bugs.gnu.org/21093>. - (x-raw-file . ,cached)) - #f) - (not-found request)))) + (cond ((file-exists? cached) + (values `((content-type . (application/octet-stream + (charset . "ISO-8859-1"))) + ,@(if ttl + `((cache-control (max-age . ,ttl))) + '()) + + ;; XXX: We're not returning the actual contents, deferring + ;; instead to 'http-write'. This is a hack to work around + ;; <http://bugs.gnu.org/21093>. + (x-raw-file . ,cached)) + #f)) + ((let* ((hash (and=> (string-index store-item #\-) + (cut string-take store-item <>))) + (item (and hash + (guard (c ((store-error? c) #f)) + (hash-part->path store hash))))) + (and item (not (string-null? item)) + (bypass-cache? store item))) + ;; Render STORE-ITEM live. We reach this because STORE-ITEM is + ;; being baked but clients are already asking for it. Thus, we're + ;; duplicating work, but doing so allows us to reduce delays. + (render-nar store request store-item + #:compression (low-compression compression))) + (else + (not-found request))))) (define (render-content-addressed-file store request name algo hash) @@ -686,6 +736,13 @@ to compress or decompress the log file; just return it as-is." (values (response-headers log) log) (not-found request)))) +(define (render-signing-key) + "Render signing key." + (let ((file %public-key-file)) + (values `((content-type . (text/plain (charset . "UTF-8"))) + (x-raw-file . ,file)) + file))) + (define (render-home-page request) "Render the home page." (values `((content-type . (text/html (charset . "UTF-8")))) @@ -699,7 +756,12 @@ to compress or decompress the log file; just return it as-is." (a (@ (href "https://guix.gnu.org/manual/en/html_node/Invoking-guix-publish.html")) (tt "guix publish")) - " speaking. Welcome!"))) + " speaking. Welcome!") + (p "Here is the " + (a (@ (href + "signing-key.pub")) + (tt "signing key")) + " for this server. Knock yourselves out!"))) port))))) (define (extract-narinfo-hash str) @@ -918,6 +980,9 @@ methods, return the applicable compression." ;; / ((or () ("index.html")) (render-home-page request)) + ;; guix signing-key + (("signing-key.pub") + (render-signing-key)) ;; /<hash>.narinfo (((= extract-narinfo-hash (? string? hash))) (if cache @@ -1061,7 +1126,10 @@ methods, return the applicable compression." consider using the '--user' option!~%"))) (parameterize ((%public-key public-key) - (%private-key private-key)) + (%private-key private-key) + (cache-bypass-threshold + (or (assoc-ref opts 'cache-bypass-threshold) + (cache-bypass-threshold)))) (info (G_ "publishing ~a on ~a, port ~d~%") %store-directory (inet-ntop (sockaddr:fam address) (sockaddr:addr address)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 7ec170b08a..ddb885d344 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -656,7 +656,7 @@ print a warning and return #f." (get-bytevector-n port len) (read-to-eof port)) (cache-narinfo! url (hash-part->path hash-part) #f - (if (= 404 code) + (if (or (= 404 code) (= 202 code)) ttl %narinfo-transient-error-ttl)) result)))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9ed5c26483..ad998156c2 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -385,6 +385,8 @@ STORE is an open connection to the store." (params (first (profile-boot-parameters %system-profile (list number)))) (locale (boot-parameters-locale params)) + (store-directory-prefix + (boot-parameters-store-directory-prefix params)) (old-generations (delv number (reverse (generation-numbers %system-profile)))) (old-params (profile-boot-parameters @@ -398,6 +400,7 @@ STORE is an open connection to the store." ((bootloader-configuration-file-generator bootloader) bootloader-config entries #:locale locale + #:store-directory-prefix store-directory-prefix #:old-entries old-entries))) (drvs -> (list bootcfg))) (mbegin %store-monad diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index d89caf80fc..5581e12892 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -204,7 +204,8 @@ services as defined by OS." ;;; Bootloader configuration. ;;; -(define (install-bootloader-program installer bootloader-package bootcfg +(define (install-bootloader-program installer disk-installer + bootloader-package bootcfg bootcfg-file device target) "Return an executable store item that, upon being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device, @@ -246,10 +247,17 @@ BOOTLOADER-PACKAGE." ;; a broken installation. (switch-symlinks new-gc-root #$bootcfg) (install-boot-config #$bootcfg #$bootcfg-file #$target) - (when #$installer + (when (or #$installer #$disk-installer) (catch #t (lambda () - (#$installer #$bootloader-package #$device #$target)) + ;; The bootloader might not support installation on a + ;; mounted directory using the BOOTLOADER-INSTALLER + ;; procedure. In that case, fallback to installing the + ;; bootloader directly on DEVICE using the + ;; BOOTLOADER-DISK-IMAGE-INSTALLER procedure. + (if #$installer + (#$installer #$bootloader-package #$device #$target) + (#$disk-installer #$bootloader-package 0 #$device))) (lambda args (delete-file new-gc-root) (match args @@ -272,11 +280,14 @@ additional configurations specified by MENU-ENTRIES can be selected." (let* ((bootloader (bootloader-configuration-bootloader configuration)) (installer (and run-installer? (bootloader-installer bootloader))) + (disk-installer (and run-installer? + (bootloader-disk-image-installer bootloader))) (package (bootloader-package bootloader)) (device (bootloader-configuration-target configuration)) (bootcfg-file (bootloader-configuration-file bootloader))) (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (primitive-load #$(install-bootloader-program installer + disk-installer package bootcfg bootcfg-file diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index 5ec844328e..1ee8937acf 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -21,6 +21,7 @@ #:use-module (guix ui) #:use-module (guix scripts package) #:use-module (guix scripts build) + #:use-module (guix transformations) #:use-module (guix scripts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -41,8 +42,6 @@ This is an alias for 'guix package -u'.\n")) (newline) (show-build-options-help) (newline) - (show-transformation-options-help) - (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " |