diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/inferior.scm | 28 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 39 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 153 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 55 | ||||
| -rw-r--r-- | guix/ssh.scm | 40 |
5 files changed, 224 insertions, 91 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm index ccc1c27cb2..973bd5264e 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -54,6 +54,7 @@ #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior + port->inferior close-inferior inferior-eval inferior-eval-with-store @@ -93,10 +94,11 @@ ;; Inferior Guix process. (define-record-type <inferior> - (inferior pid socket version packages table) + (inferior pid socket close version packages table) inferior? (pid inferior-pid) (socket inferior-socket) + (close inferior-close-socket) ;procedure (version inferior-version) ;REPL protocol version (packages inferior-package-promise) ;promise of inferior packages (table inferior-package-table)) ;promise of vhash @@ -131,19 +133,17 @@ it's an old Guix." ((@ (guix scripts repl) machine-repl)))))) pipe))) -(define* (open-inferior directory #:key (command "bin/guix")) - "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or -equivalent. Return #f if the inferior could not be launched." - (define pipe - (inferior-pipe directory command)) - +(define* (port->inferior pipe #:optional (close close-port)) + "Given PIPE, an input/output port, return an inferior that talks over PIPE. +PIPE is closed with CLOSE when 'close-inferior' is called on the returned +inferior." (cond-expand ((and guile-2 (not guile-2.2)) #t) (else (setvbuf pipe 'line))) (match (read pipe) (('repl-version 0 rest ...) - (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) @@ -155,9 +155,18 @@ equivalent. Return #f if the inferior could not be launched." (_ #f))) +(define* (open-inferior directory #:key (command "bin/guix")) + "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or +equivalent. Return #f if the inferior could not be launched." + (define pipe + (inferior-pipe directory command)) + + (port->inferior pipe close-pipe)) + (define (close-inferior inferior) "Close INFERIOR." - (close-pipe (inferior-socket inferior))) + (let ((close (inferior-close-socket inferior))) + (close (inferior-socket inferior)))) ;; Non-self-quoting object of the inferior. (define-record-type <inferior-object> @@ -409,6 +418,7 @@ thus be the code of a one-argument procedure that accepts a store." ;; Create a named socket in /tmp and let INFERIOR connect to it and use it ;; as its store. This ensures the inferior uses the same store, with the ;; same options, the same per-session GC roots, etc. + ;; FIXME: This strategy doesn't work for remote inferiors (SSH). (call-with-temporary-directory (lambda (directory) (chmod directory #o700) 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) diff --git a/guix/ssh.scm b/guix/ssh.scm index 104f4f52d6..1ed8406633 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -18,6 +18,7 @@ (define-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix i18n) #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ssh session) @@ -26,8 +27,6 @@ #:use-module (ssh channel) #:use-module (ssh popen) #:use-module (ssh session) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -36,6 +35,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:export (open-ssh-session + remote-inferior remote-daemon-channel connect-to-remote-daemon send-files @@ -94,6 +94,26 @@ Throw an error on failure." (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") host (get-error session)))))))))) +(define (remote-inferior session) + "Return a remote inferior for the given SESSION." + (let ((pipe (open-remote-pipe* session OPEN_BOTH + "guix" "repl" "-t" "machine"))) + (port->inferior pipe))) + +(define (inferior-remote-eval exp session) + "Evaluate EXP in a new inferior running in SESSION, and close the inferior +right away." + (let ((inferior (remote-inferior session))) + (dynamic-wind + (const #t) + (lambda () + (inferior-eval exp inferior)) + (lambda () + ;; Close INFERIOR right away to prevent finalization from happening in + ;; another thread at the wrong time (see + ;; <https://bugs.gnu.org/26976>.) + (close-inferior inferior))))) + (define* (remote-daemon-channel session #:optional (socket-name @@ -269,15 +289,15 @@ Return the list of store items actually sent." ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) + (missing (inferior-remote-eval + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) - (with-store store - (remove (cut valid-path? store <>) - ',files))))) + (with-store store + (remove (cut valid-path? store <>) + ',files))) + session)) (count (length missing)) (sizes (map (lambda (item) (path-info-nar-size (query-path-info local item))) |