diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/lint.scm | 39 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 153 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 55 |
3 files changed, 175 insertions, 72 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2314f3b28c..354f6f7031 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,8 +45,10 @@ #: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) #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors @@ -74,6 +77,7 @@ check-source check-source-file-name check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -773,6 +777,37 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) +(define (check-github-url package) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect uri) + (receive (response body) (http-head uri) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (for-each + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source)))) + (origin-uris origin))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try system) @@ -1056,6 +1091,10 @@ or a list thereof") (description "Suggest 'mirror://' URLs") (check check-mirror-url)) (lint-checker + (name 'github-uri) + (description "Suggest GitHub URIs") + (check check-github-url)) + (lint-checker (name 'source-file-name) (description "Validate file names of sources") (check check-source-file-name)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bfdaa3c011..dcdccc80e0 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,13 +23,12 @@ #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh popen) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix derivations) #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) @@ -321,12 +320,15 @@ hook." (set-port-revealed! port 1) port)) +(define (node-guile-version node) + (inferior-eval '(version) node)) + (define (node-free-disk-space node) "Return the free disk space, in bytes, in NODE's store." - (node-eval node - `(begin - (use-modules (guix build syscalls)) - (free-disk-space ,(%store-prefix))))) + (inferior-eval `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))) + node)) (define* (transfer-and-offload drv machine #:key @@ -367,8 +369,12 @@ MACHINE." (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) - (let* ((space (false-if-exception - (node-free-disk-space (make-node session))))) + (let* ((inferior (false-if-exception (remote-inferior session))) + (space (false-if-exception + (node-free-disk-space inferior)))) + + (when inferior + (close-inferior inferior)) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -417,11 +423,11 @@ of free disk space on '~a'~%") (define (node-load node) "Return the load on NODE. Return +∞ if NODE is misbehaving." - (let ((line (node-eval node - '(begin - (use-modules (ice-9 rdelim)) - (call-with-input-file "/proc/loadavg" - read-string))))) + (let ((line (inferior-eval '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string)) + node))) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded (match (string-tokenize line) @@ -508,9 +514,10 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best))) - (node (and session (make-node session))) + (node (and session (remote-inferior session))) (load (and node (normalized-load best (node-load node)))) (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) (when session (disconnect! session)) (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others @@ -613,40 +620,34 @@ If TIMEOUT is #f, simply evaluate EXP..." (#f (report-guile-error name)) ((? string? version) - ;; Note: The version string already contains the word "Guile". - (info (G_ "'~a' is running ~a~%") + (info (G_ "'~a' is running GNU Guile ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) - "Bail out if NODE lacks the (guix) module, or if its daemon is not running." - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + "Bail out if NODE if #f or if we fail to use the (guix) module, or if its +daemon is not running." + (unless (inferior? node) + (leave (G_ "failed to run 'guix repl' on '~a'~%") name)) + + (match (inferior-eval '(begin (use-modules (guix)) - (and add-text-to-store 'alright))) - ('alright #t) - (_ (report-module-error name)))) - (lambda (key . args) - (report-module-error name))) + (and add-text-to-store 'alright)) + node) + ('alright #t) + (_ (report-module-error name))) - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + (match (inferior-eval '(begin (use-modules (guix)) (with-store store (add-text-to-store store "test" - "Hello, build machine!")))) - ((? string? str) - (info (G_ "Guix is usable on '~a' (test returned ~s)~%") - name str)) - (x - (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") - name x)))) - (lambda (key . args) - (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") - name args)))) + "Hello, build machine!"))) + node) + ((? string? str) + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") + name x)))) (define %random-state (delay @@ -656,25 +657,23 @@ If TIMEOUT is #f, simply evaluate EXP..." (string-append name "-" (number->string (random 1000000 (force %random-state))))) -(define (assert-node-can-import node name daemon-socket) +(define (assert-node-can-import session node name daemon-socket) "Bail out if NODE refuses to import our archives." - (let ((session (node-session node))) - (with-store store - (let* ((item (add-text-to-store store "export-test" (nonce))) - (remote (connect-to-remote-daemon session daemon-socket))) - (with-store local - (send-files local (list item) remote)) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) - (if (valid-path? remote item) - (info (G_ "'~a' successfully imported '~a'~%") - name item) - (leave (G_ "'~a' was not properly imported on '~a'~%") - item name)))))) + (if (valid-path? remote item) + (info (G_ "'~a' successfully imported '~a'~%") + name item) + (leave (G_ "'~a' was not properly imported on '~a'~%") + item name))))) -(define (assert-node-can-export node name daemon-socket) +(define (assert-node-can-export session node name daemon-socket) "Bail out if we cannot import signed archives from NODE." - (let* ((session (node-session node)) - (remote (connect-to-remote-daemon session daemon-socket)) + (let* ((remote (connect-to-remote-daemon session daemon-socket)) (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store (if (and (retrieve-files store (list item) remote) @@ -701,11 +700,13 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map open-ssh-session machines)) - (nodes (map make-node sessions))) - (for-each assert-node-repl nodes names) + (nodes (map remote-inferior sessions))) (for-each assert-node-has-guix nodes names) - (for-each assert-node-can-import nodes names sockets) - (for-each assert-node-can-export nodes names sockets)))) + (for-each assert-node-repl nodes names) + (for-each assert-node-can-import sessions nodes names sockets) + (for-each assert-node-can-export sessions nodes names sockets) + (for-each close-inferior nodes) + (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) "Print the load of each machine matching PRED in MACHINE-FILE." @@ -721,20 +722,28 @@ machine." (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((session (open-ssh-session machine)) - (node (make-node session)) - (uts (node-eval node '(uname))) - (load (node-load node)) - (free (node-free-disk-space node))) - (disconnect! session) - (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + (define session + (open-ssh-session machine)) + + (match (remote-inferior session) + (#f + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (build-machine-name machine))) + ((? inferior? inferior) + (let ((uts (inferior-eval '(uname) inferior)) + (load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" - (build-machine-name machine) - (utsname:sysname uts) (utsname:release uts) - (utsname:machine uts) - (utsname:nodename uts) - (normalized-load machine load) - (/ free (expt 2 20) 1.)))) + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (normalized-load machine load) + (/ free (expt 2 20) 1.))))) + + (disconnect! session)) machines))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 1d86f949c8..003c915da3 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) + #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -88,6 +90,12 @@ (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) + (option '("list-transitive") #f #f + (lambda (opt name arg result) + (alist-cons 'list-transitive? #t result))) (option '("keyring") #t #f (lambda (opt name arg result) @@ -140,6 +148,10 @@ specified with `--select'.\n")) (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) + (display (G_ " + -r, --recursive check the PACKAGE and its inputs for upgrades")) + (display (G_ " + --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) @@ -323,6 +335,43 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) +(define (refresh-recursive packages) + "Check all of the package inputs of PACKAGES for newer upstream versions." + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + ;; par-for-each has an undefined return value, so packages which cause + ;; errors can be ignored. + (par-for-each (lambda (package) + (guix-refresh package)) + (map package-name dependent))) + (return #t))) + +(define (list-transitive packages) + "List all the packages that would cause PACKAGES to be rebuilt if they are changed." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + (match packages + ((x) + (format (current-output-port) + (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") + (full-name x) (length dependent) (map full-name dependent))) + (lst + (format (current-output-port) + (G_ "The following ~d packages \ +all are dependent packages: ~{~a~^ ~}~%") + (length dependent) (map full-name dependent)))) + (return #t)))) + ;;; ;;; Manifest. @@ -402,7 +451,9 @@ update would trigger a complete rebuild." (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) + (recursive? (assoc-ref opts 'recursive?)) (list-dependent? (assoc-ref opts 'list-dependent?)) + (list-transitive? (assoc-ref opts 'list-transitive?)) (key-download (assoc-ref opts 'key-download)) ;; Warn about missing updaters when a package is explicitly given on @@ -441,6 +492,10 @@ update would trigger a complete rebuild." (cond (list-dependent? (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (recursive? + (refresh-recursive packages)) (update? (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) |