diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 107 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 102 |
3 files changed, 132 insertions, 87 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fc0c0e2ad3..ba143ad16b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -635,8 +635,7 @@ options handled by 'set-build-options-from-command-line', and listed in (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) - (build-mode . ,(build-mode normal)) + `((build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -729,8 +728,7 @@ must be one of 'package', 'all', or 'transitive'~%") rest))) (option '(#\s "system") #t #f (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) + (alist-cons 'system arg result))) (option '("target") #t #f (lambda (opt name arg result) (alist-cons 'target arg @@ -811,56 +809,71 @@ build." (cut package-cross-derivation <> <> triplet <>)))) (define src (assoc-ref opts 'source)) - (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) + (define systems + (match (filter-map (match-lambda + (('system . system) system) + (_ #f)) + opts) + (() (list (%current-system))) + (systems systems))) + + (define things-to-build + (map (cut transform store <>) + (options->things-to-build opts))) + + (define (compute-derivation obj system) + ;; Compute the derivation of OBJ for SYSTEM. + (match obj + ((? package? p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (G_ "~a: warning: \ +package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? file-like? obj) + (list (run-with-store store + (lower-object obj system + #:target (assoc-ref opts 'target)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)) + #:system system))))) ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields ;; of user packages. Since 'guix build' is the primary tool for people ;; testing new packages, report such errors gracefully. (with-unbound-variable-handling (parameterize ((%graft? graft?)) - (append-map (match-lambda - ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (G_ "~a: warning: \ -package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) - ((? derivation? drv) - (list drv)) - ((? procedure? proc) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - ((? file-like? obj) - (list (run-with-store store - (lower-object obj system - #:target (assoc-ref opts 'target)) - #:system system))) - ((? gexp? gexp) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system)) - #:system system)))) - (map (cut transform store <>) - (options->things-to-build opts)))))) + (append-map (lambda (system) + (append-map (cut compute-derivation <> system) + things-to-build)) + systems)))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index ddad5b7fd0..dc338a1d7b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -45,7 +45,6 @@ #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) - #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) #:use-module (web client) @@ -796,10 +795,13 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) -(define (check-github-url package) +(define* (check-github-url package #:key (timeout 3)) "Check whether PACKAGE uses source URLs that redirect to GitHub." - (define (follow-redirect uri) - (receive (response body) (http-head uri) + (define (follow-redirect url) + (let* ((uri (string->uri url)) + (port (guix:open-connection-for-uri uri #:timeout timeout)) + (response (http-head uri #:port port))) + (close-port port) (case (response-code response) ((301 302) (uri->string (assoc-ref (response-headers response) 'location))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 55137fce8f..3929cd402e 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -86,6 +86,8 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --branch=BRANCH download the tip of the specified BRANCH")) (display (G_ " + -N, --news display news compared to the previous generation")) + (display (G_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) (display (G_ " @@ -117,6 +119,9 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) result))) + (option '(#\N "news") #f #f + (lambda (opt name arg result) + (cons '(query display-news) result))) (option '("url") #t #f (lambda (opt name arg result) (alist-cons 'repository-url arg @@ -162,25 +167,33 @@ Download and deploy the latest version of Guix.\n")) (define indirect-root-added (store-lift add-indirect-root)) -(define (display-profile-news profile) - "Display what's up in PROFILE--new packages, and all that." +(define* (display-profile-news profile #:key concise? + current-is-newer?) + "Display what's up in PROFILE--new packages, and all that. If +CURRENT-IS-NEWER? is true, assume that the current process represents the +newest generation of PROFILE.x" (match (memv (generation-number profile) (reverse (profile-generations profile))) ((current previous _ ...) - (newline) - (let ((old (fold-available-packages - (lambda* (name version result - #:key supported? deprecated? - #:allow-other-keys) - (if (and supported? (not deprecated?)) - (alist-cons name version result) - result)) - '())) - (new (profile-package-alist - (generation-file-name profile current)))) - (display-new/upgraded-packages old new - #:concise? #t - #:heading (G_ "New in this revision:\n")))) + (let ((these (fold-available-packages + (lambda* (name version result + #:key supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (alist-cons name version result) + result)) + '())) + (those (profile-package-alist + (generation-file-name profile + (if current-is-newer? + previous + current))))) + (let ((old (if current-is-newer? those these)) + (new (if current-is-newer? these those))) + (display-new/upgraded-packages old new + #:concise? concise? + #:heading + (G_ "New in this revision:\n"))))) (_ #t))) (define* (build-and-install instances profile @@ -196,7 +209,8 @@ true, display what would be built without actually building it." #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)) + (return (newline)) + (return (display-profile-news profile #:concise? #t)) (match (which "guix") (#f (return #f)) (str @@ -394,9 +408,13 @@ display long package lists that would fill the user's screen." column) 4)) + (define concise/max-item-count + ;; Maximum number of items to display when CONCISE? is true. + 12) + (define list->enumeration (if concise? - (lambda* (lst #:optional (max 12)) + (lambda* (lst #:optional (max concise/max-item-count)) (if (> (length lst) max) (string-append (string-join (take lst max) ", ") ", " (ellipsis)) @@ -404,10 +422,13 @@ display long package lists that would fill the user's screen." (cut string-join <> ", "))) (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) + (define new-count (length new)) + (define upgraded-count (length upgraded)) + (unless (and (null? new) (null? upgraded)) (display heading)) - (match (length new) + (match new-count (0 #t) (count (format #t (N_ " ~h new package: ~a~%" @@ -415,14 +436,20 @@ display long package lists that would fill the user's screen." count (pretty (list->enumeration (sort (map first new) string<?)) 30)))) - (match (length upgraded) + (match upgraded-count (0 #t) (count (format #t (N_ " ~h package upgraded: ~a~%" " ~h packages upgraded: ~a~%" count) count (pretty (list->enumeration (sort upgraded string<?)) - 35)))))) + 35)))) + + (when (and concise? + (or (> new-count concise/max-item-count) + (> upgraded-count concise/max-item-count))) + (display-hint (G_ "Run @command{guix pull --news} to view the complete +list of package changes."))))) (define (display-profile-content-diff profile gen1 gen2) "Display the changes in PROFILE GEN2 compared to generation GEN1." @@ -462,7 +489,12 @@ display long package lists that would fill the user's screen." (() (exit 1)) ((numbers ...) - (list-generations profile numbers))))))))) + (list-generations profile numbers))))))) + (('display-news) + ;; Display profile news, with the understanding that this process + ;; represents the newest generation. + (display-profile-news profile + #:current-is-newer? #t)))) (define (channel-list opts) "Return the list of channels to use. If OPTS specify a channel file, @@ -502,24 +534,22 @@ Use '~/.config/guix/channels.scm' instead.")) (url (or (assoc-ref opts 'repository-url) (environment-variable)))) (if (or ref url) - (match channels - ((one) - ;; When there's only one channel, apply '--url', '--commit', and - ;; '--branch' to this specific channel. - (let ((url (or url (channel-url one)))) - (list (match ref + (match (find guix-channel? channels) + ((? channel? guix) + ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel. + (let ((url (or url (channel-url guix)))) + (cons (match ref (('commit . commit) - (channel (inherit one) + (channel (inherit guix) (url url) (commit commit) (branch #f))) (('branch . branch) - (channel (inherit one) + (channel (inherit guix) (url url) (commit #f) (branch branch))) (#f - (channel (inherit one) (url url))))))) - (_ - ;; Otherwise bail out. - (leave - (G_ "'--url', '--commit', and '--branch' are not applicable~%")))) + (channel (inherit guix) (url url)))) + (remove guix-channel? channels)))) + (#f ;no 'guix' channel, failure will ensue + channels)) channels))) @@ -531,11 +561,11 @@ Use '~/.config/guix/channels.scm' instead.")) (cache (string-append (cache-directory) "/pull")) (channels (channel-list opts)) (profile (or (assoc-ref opts 'profile) %current-profile))) - (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) (else (with-store store + (ensure-default-profile) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?)) |