summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorHartmut Goebel <h.goebel@crazy-compilers.com>2016-11-29 18:47:16 +0100
committerHartmut Goebel <h.goebel@crazy-compilers.com>2016-11-29 18:47:16 +0100
commit3bf428065916f1a47c5ed12f5622f0eff4123644 (patch)
treef424c57b8a00a019e04fc29f42c8527a811ba281 /guix
parent2cb64f3b1b3df338acfc0ba9f719875db21812b0 (diff)
parent683c5ab70accb909697717bb61741a7692c52c09 (diff)
Merge branch 'master' into python-build-system
Diffstat (limited to 'guix')
-rw-r--r--guix/build/pull.scm2
-rw-r--r--guix/gnu-maintenance.scm3
-rw-r--r--guix/scripts/offload.scm630
-rw-r--r--guix/scripts/refresh.scm96
-rw-r--r--guix/store.scm58
-rw-r--r--guix/upstream.scm30
6 files changed, 397 insertions, 422 deletions
diff --git a/guix/build/pull.scm b/guix/build/pull.scm
index 871bf6f535..6034e93cbf 100644
--- a/guix/build/pull.scm
+++ b/guix/build/pull.scm
@@ -84,7 +84,7 @@ containing the source code. Write any debugging output to DEBUG-PORT."
(("@GZIP@") (string-append gzip "/bin/gzip"))
(("@BZIP2@") (string-append bzip2 "/bin/bzip2"))
(("@XZ@") (string-append xz "/bin/xz"))
- (("@NIX_INSTANTIATE@") "")) ;remnants from the past
+ (("@NIX_INSTANTIATE@") "nix-instantiate")) ;for (guix import nix)
;; Augment the search path so Scheme code can be compiled.
(set! %load-path (cons out %load-path))
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 78392c9a11..6c6c0722d5 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -525,7 +525,8 @@ elpa.gnu.org, and all the GNOME packages."
(let ((uri (string->uri (origin-uri (package-source package)))))
(false-if-ftp-error
(latest-ftp-release
- (package-name package)
+ (or (assoc-ref (package-properties package) 'upstream-name)
+ (package-name package))
#:server "mirrors.mit.edu"
#:directory
(string-append "/kde" (dirname (dirname (uri-path uri))))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 33d141e7ef..bc024a8701 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -17,6 +17,13 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts offload)
+ #:use-module (ssh key)
+ #:use-module (ssh auth)
+ #:use-module (ssh session)
+ #:use-module (ssh channel)
+ #:use-module (ssh popen)
+ #:use-module (ssh dist)
+ #:use-module (ssh dist node)
#:use-module (guix config)
#:use-module (guix records)
#:use-module (guix store)
@@ -65,14 +72,15 @@
(system build-machine-system) ; string
(user build-machine-user) ; string
(private-key build-machine-private-key ; file name
- (default (user-lsh-private-key)))
+ (default (user-openssh-private-key)))
+ (host-key build-machine-host-key) ; string
+ (daemon-socket build-machine-daemon-socket ; string
+ (default "/var/guix/daemon-socket/socket"))
(parallel-builds build-machine-parallel-builds ; number
(default 1))
(speed build-machine-speed ; inexact real
(default 1.0))
(features build-machine-features ; list of strings
- (default '()))
- (ssh-options build-machine-ssh-options ; list of strings
(default '())))
(define-record-type* <build-requirements>
@@ -86,19 +94,11 @@
;; File that lists machines available as build slaves.
(string-append %config-directory "/machines.scm"))
-(define %lsh-command
- "lsh")
-
-(define %lshg-command
- ;; FIXME: 'lshg' fails to pass large amounts of data, see
- ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
- "lsh")
-
-(define (user-lsh-private-key)
- "Return the user's default lsh private key, or #f if it could not be
+(define (user-openssh-private-key)
+ "Return the user's default SSH private key, or #f if it could not be
determined."
(and=> (getenv "HOME")
- (cut string-append <> "/.lsh/identity")))
+ (cut string-append <> "/.ssh/id_rsa")))
(define %user-module
;; Module in which the machine description file is loaded.
@@ -134,81 +134,120 @@ determined."
(leave (_ "failed to load machine file '~a': ~s~%")
file args))))))
-;;; FIXME: The idea was to open the connection to MACHINE once for all, but
-;;; lshg is currently non-functional.
-;; (define (open-ssh-gateway machine)
-;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the
-;; running lsh gateway upon success, or #f on failure."
-;; (catch 'system-error
-;; (lambda ()
-;; (let* ((port (open-pipe* OPEN_READ %lsh-command
-;; "-l" (build-machine-user machine)
-;; "-i" (build-machine-private-key machine)
-;; ;; XXX: With lsh 2.1, passing '--write-pid'
-;; ;; last causes the PID not to be printed.
-;; "--write-pid" "--gateway" "--background"
-;; (build-machine-name machine)))
-;; (line (read-line port))
-;; (status (close-pipe port)))
-;; (if (zero? status)
-;; (let ((pid (string->number line)))
-;; (if (integer? pid)
-;; pid
-;; (begin
-;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
-;; %lsh-command line)
-;; #f)))
-;; (begin
-;; (warning (_ "failed to initiate SSH connection to '~a':\
-;; '~a' exited with ~a~%")
-;; (build-machine-name machine)
-;; %lsh-command
-;; (status:exit-val status))
-;; #f))))
-;; (lambda args
-;; (leave (_ "failed to execute '~a': ~a~%")
-;; %lsh-command (strerror (system-error-errno args))))))
-
-(define-syntax with-error-to-port
- (syntax-rules ()
- ((_ port exp0 exp ...)
- (let ((new port)
- (old (current-error-port)))
- (dynamic-wind
- (lambda ()
- (set-current-error-port new))
- (lambda ()
- exp0 exp ...)
- (lambda ()
- (set-current-error-port old)))))))
-
-(define* (remote-pipe machine mode command
- #:key (error-port (current-error-port)) (quote? #t))
- "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
-set up. When QUOTE? is true, perform shell-quotation of all the elements of
-COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could
-not be started."
- (define (shell-quote str)
- ;; Sort-of shell-quote STR so it can be passed as an argument to the
- ;; shell.
- (with-output-to-string
- (lambda ()
- (write str))))
-
- ;; Let the child inherit ERROR-PORT.
- (with-error-to-port error-port
- (apply open-pipe* mode %lshg-command
- "-l" (build-machine-user machine)
- "-p" (number->string (build-machine-port machine))
-
- ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
- "-i" (build-machine-private-key machine)
-
- (append (build-machine-ssh-options machine)
- (list (build-machine-name machine))
- (if quote?
- (map shell-quote command)
- command)))))
+(define (host-key->type+key host-key)
+ "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
+its key type as a symbol, and the actual base64-encoded string."
+ (define (type->symbol type)
+ (and (string-prefix? "ssh-" type)
+ (string->symbol (string-drop type 4))))
+
+ (match (string-tokenize host-key)
+ ((type key _)
+ (values (type->symbol type) key))
+ ((type key)
+ (values (type->symbol type) key))))
+
+(define (private-key-from-file* file)
+ "Like 'private-key-from-file', but raise an error that 'with-error-handling'
+can interpret meaningfully."
+ (catch 'guile-ssh-error
+ (lambda ()
+ (private-key-from-file file))
+ (lambda (key proc str . rest)
+ (raise (condition
+ (&message (message (format #f (_ "failed to load SSH \
+private key from '~a': ~a")
+ file str))))))))
+
+(define (open-ssh-session machine)
+ "Open an SSH session for MACHINE and return it. Throw an error on failure."
+ (let ((private (private-key-from-file* (build-machine-private-key machine)))
+ (public (public-key-from-file
+ (string-append (build-machine-private-key machine)
+ ".pub")))
+ (session (make-session #:user (build-machine-user machine)
+ #:host (build-machine-name machine)
+ #:port (build-machine-port machine)
+ #:timeout 5 ;seconds
+ ;; #:log-verbosity 'protocol
+ #:identity (build-machine-private-key machine)
+
+ ;; We need lightweight compression when
+ ;; exchanging full archives.
+ #:compression "zlib"
+ #:compression-level 3)))
+ (connect! session)
+
+ ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about
+ ;; ed25519 keys and 'get-key-type' returns #f in that case.
+ (let-values (((server) (get-server-public-key session))
+ ((type key) (host-key->type+key
+ (build-machine-host-key machine))))
+ (unless (and (or (not (get-key-type server))
+ (eq? (get-key-type server) type))
+ (string=? (public-key->string server) key))
+ ;; Key mismatch: something's wrong. XXX: It could be that the server
+ ;; provided its Ed25519 key when we where expecting its RSA key.
+ (leave (_ "server at '~a' returned host key '~a' of type '~a' \
+instead of '~a' of type '~a'~%")
+ (build-machine-name machine)
+ (public-key->string server) (get-key-type server)
+ key type)))
+
+ (let ((auth (userauth-public-key! session private)))
+ (unless (eq? 'success auth)
+ (disconnect! session)
+ (leave (_ "SSH public key authentication failed for '~a': ~a~%")
+ (build-machine-name machine) (get-error session))))
+
+ session))
+
+(define* (connect-to-remote-daemon session
+ #:optional
+ (socket-name "/var/guix/daemon-socket/socket"))
+ "Connect to the remote build daemon listening on SOCKET-NAME over SESSION,
+an SSH session. Return a <nix-server> object."
+ (define redirect
+ ;; Code run in SESSION to redirect the remote process' stdin/stdout to the
+ ;; daemon's socket, à la socat. The SSH protocol supports forwarding to
+ ;; Unix-domain sockets but libssh doesn't have an API for that, hence this
+ ;; hack.
+ `(begin
+ (use-modules (ice-9 match) (rnrs io ports))
+
+ (let ((sock (socket AF_UNIX SOCK_STREAM 0))
+ (stdin (current-input-port))
+ (stdout (current-output-port)))
+ (setvbuf stdin _IONBF)
+ (setvbuf stdout _IONBF)
+ (connect sock AF_UNIX ,socket-name)
+
+ (let loop ()
+ (match (select (list stdin sock) '() (list stdin stdout sock))
+ ((reads writes ())
+ (when (memq stdin reads)
+ (match (get-bytevector-some stdin)
+ ((? eof-object?)
+ (primitive-exit 0))
+ (bv
+ (put-bytevector sock bv))))
+ (when (memq sock reads)
+ (match (get-bytevector-some sock)
+ ((? eof-object?)
+ (primitive-exit 0))
+ (bv
+ (put-bytevector stdout bv))))
+ (loop))
+ (_
+ (primitive-exit 1)))))))
+
+ (let ((channel
+ (open-remote-pipe* session OPEN_BOTH
+ ;; Sort-of shell-quote REDIRECT.
+ "guile" "-c"
+ (object->string
+ (object->string redirect)))))
+ (open-connection #:port channel)))
;;;
@@ -299,113 +338,6 @@ hook."
(set-port-revealed! port 1)
port))
-(define %gc-root-file
- ;; File name of the temporary GC root we install.
- (format #f "offload-~a-~a" (gethostname) (getpid)))
-
-(define (register-gc-root file machine)
- "Mark FILE, a store item, as a garbage collector root on MACHINE."
- (define script
- `(begin
- (use-modules (guix config))
-
- ;; Note: we can't use 'add-indirect-root' because dangling links under
- ;; gcroots/auto are automatically deleted by the GC. This strategy
- ;; doesn't have this problem, but it requires write access to that
- ;; directory.
- (let ((root-directory (string-append %state-directory
- "/gcroots/tmp")))
- (catch 'system-error
- (lambda ()
- (mkdir root-directory))
- (lambda args
- (unless (= EEXIST (system-error-errno args))
- (error "failed to create remote GC root directory"
- root-directory (system-error-errno args)))))
-
- (catch 'system-error
- (lambda ()
- (symlink ,file
- (string-append root-directory "/" ,%gc-root-file)))
- (lambda args
- ;; If FILE already exists, we can assume that either it's a stale
- ;; reference (which is fine), or another process is already
- ;; building the derivation represented by FILE (which is fine
- ;; too.) Thus, do nothing in that case.
- (unless (= EEXIST (system-error-errno args))
- (apply throw args)))))))
-
- (let ((pipe (remote-pipe machine OPEN_READ
- `("guile" "-c" ,(object->string script)))))
- (read-string pipe)
- (let ((status (close-pipe pipe)))
- (unless (zero? status)
- ;; Better be safe than sorry: if we ignore the error here, then FILE
- ;; may be GC'd just before we start using it.
- (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
- file (build-machine-name machine) status)))))
-
-(define (remove-gc-roots machine)
- "Remove from MACHINE the GC roots previously installed with
-'register-gc-root'."
- (define script
- `(begin
- (use-modules (guix config) (ice-9 ftw)
- (srfi srfi-1) (srfi srfi-26))
-
- (let ((root-directory (string-append %state-directory
- "/gcroots/tmp")))
- (false-if-exception
- (delete-file
- (string-append root-directory "/" ,%gc-root-file)))
-
- ;; These ones were created with 'guix build -r' (there can be more
- ;; than one in case of multiple-output derivations.)
- (let ((roots (filter (cut string-prefix? ,%gc-root-file <>)
- (scandir "."))))
- (for-each (lambda (file)
- (false-if-exception (delete-file file)))
- roots)))))
-
- (let ((pipe (remote-pipe machine OPEN_READ
- `("guile" "-c" ,(object->string script)))))
- (read-string pipe)
- (close-pipe pipe)))
-
-(define* (offload drv machine
- #:key print-build-trace? (max-silent-time 3600)
- build-timeout (log-port (build-log-port)))
- "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
-there, and write the build log to LOG-PORT. Return the exit status."
- (format (current-error-port) "offloading '~a' to '~a'...~%"
- (derivation-file-name drv) (build-machine-name machine))
- (format (current-error-port) "@ build-remote ~a ~a~%"
- (derivation-file-name drv) (build-machine-name machine))
-
- ;; Normally DRV has already been protected from GC when it was transferred.
- ;; The '-r' flag below prevents the build result from being GC'd.
- (let ((pipe (remote-pipe machine OPEN_READ
- `("guix" "build"
- "-r" ,%gc-root-file
- ,(format #f "--max-silent-time=~a"
- max-silent-time)
- ,@(if build-timeout
- (list (format #f "--timeout=~a"
- build-timeout))
- '())
- ,(derivation-file-name drv))
-
- ;; Since 'guix build' writes the build log to its
- ;; stderr, everything will go directly to LOG-PORT.
- #:error-port log-port)))
- (let loop ((line (read-line pipe)))
- (unless (eof-object? line)
- (display line log-port)
- (newline log-port)
- (loop (read-line pipe))))
-
- (close-pipe pipe)))
-
(define* (transfer-and-offload drv machine
#:key
(inputs '())
@@ -416,120 +348,131 @@ there, and write the build log to LOG-PORT. Return the exit status."
"Offload DRV to MACHINE. Prior to the actual offloading, transfer all of
INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
MACHINE."
- (when (begin
- (register-gc-root (derivation-file-name drv) machine)
- (send-files (cons (derivation-file-name drv) inputs)
- machine))
- (let ((status (offload drv machine
- #:print-build-trace? print-build-trace?
- #:max-silent-time max-silent-time
- #:build-timeout build-timeout)))
- (if (zero? status)
- (begin
- (retrieve-files outputs machine)
- (remove-gc-roots machine)
- (format (current-error-port)
- "done with offloaded '~a'~%"
- (derivation-file-name drv)))
- (begin
- (remove-gc-roots machine)
- (format (current-error-port)
- "derivation '~a' offloaded to '~a' failed \
-with exit code ~a~%"
- (derivation-file-name drv)
- (build-machine-name machine)
- (status:exit-val status))
-
- ;; Use exit code 100 for a permanent build failure. The daemon
- ;; interprets other non-zero codes as transient build failures.
- (primitive-exit 100))))))
-
-(define (send-files files machine)
- "Send the subset of FILES that's missing to MACHINE's store. Return #t on
-success, #f otherwise."
- (define (missing-files files)
- ;; Return the subset of FILES not already on MACHINE.
- (let*-values (((files)
- (format #f "~{~a~%~}" files))
- ((missing pids)
- (filtered-port
- (append (list (which %lshg-command)
- "-l" (build-machine-user machine)
- "-p" (number->string
- (build-machine-port machine))
- "-i" (build-machine-private-key machine))
- (build-machine-ssh-options machine)
- (cons (build-machine-name machine)
- '("guix" "archive" "--missing")))
- (open-input-string files)))
- ((result)
- (read-string missing)))
- (for-each waitpid pids)
- (string-tokenize result)))
+ (define session
+ (open-ssh-session machine))
+ (define store
+ (connect-to-remote-daemon session
+ (build-machine-daemon-socket machine)))
+
+ (set-build-options store
+ #:print-build-trace print-build-trace?
+ #:max-silent-time max-silent-time
+ #:timeout build-timeout)
+
+ ;; Protect DRV from garbage collection.
+ (add-temp-root store (derivation-file-name drv))
+
+ (send-files (cons (derivation-file-name drv) inputs)
+ store)
+ (format (current-error-port) "offloading '~a' to '~a'...~%"
+ (derivation-file-name drv) (build-machine-name machine))
+ (format (current-error-port) "@ build-remote ~a ~a~%"
+ (derivation-file-name drv) (build-machine-name machine))
+
+ (guard (c ((nix-protocol-error? c)
+ (format (current-error-port)
+ (_ "derivation '~a' offloaded to '~a' failed: ~a~%")
+ (derivation-file-name drv)
+ (build-machine-name machine)
+ (nix-protocol-error-message c))
+ ;; Use exit code 100 for a permanent build failure. The daemon
+ ;; interprets other non-zero codes as transient build failures.
+ (primitive-exit 100)))
+ (build-derivations store (list drv)))
+
+ (retrieve-files outputs store)
+ (format (current-error-port) "done with offloaded '~a'~%"
+ (derivation-file-name drv)))
+
+(define (store-import-channel session)
+ "Return an output port to which archives to be exported to SESSION's store
+can be written."
+ ;; Using the 'import-paths' RPC on a remote store would be slow because it
+ ;; makes a round trip every time 32 KiB have been transferred. This
+ ;; procedure instead opens a separate channel to use the remote
+ ;; 'import-paths' procedure, which consumes all the data in a single round
+ ;; trip.
+ (define import
+ `(begin
+ (use-modules (guix))
+
+ (with-store store
+ (setvbuf (current-input-port) _IONBF)
+ (import-paths store (current-input-port)))))
+
+ (open-remote-output-pipe session
+ (string-join
+ `("guile" "-c"
+ ,(object->string
+ (object->string import))))))
+
+(define (store-export-channel session files)
+ "Return an input port from which an export of FILES from SESSION's store can
+be read."
+ ;; Same as above: this is more efficient than calling 'export-paths' on a
+ ;; remote store.
+ (define export
+ `(begin
+ (use-modules (guix))
+
+ (with-store store
+ (setvbuf (current-output-port) _IONBF)
+ (export-paths store ',files (current-output-port)))))
+
+ (open-remote-input-pipe session
+ (string-join
+ `("guile" "-c"
+ ,(object->string
+ (object->string export))))))
+
+(define (send-files files remote)
+ "Send the subset of FILES that's missing to REMOTE, a remote store."
(with-store store
- (guard (c ((nix-protocol-error? c)
- (warning (_ "failed to export files for '~a': ~s~%")
- (build-machine-name machine)
- c)
- #f))
-
- ;; Compute the subset of FILES missing on MACHINE, and send them in
- ;; topologically sorted order so that they can actually be imported.
- ;;
- ;; To reduce load on the machine that's offloading (since it's typically
- ;; already quite busy, see hydra.gnu.org), compress with gzip rather
- ;; than xz: For a compression ratio 2 times larger, it is 20 times
- ;; faster.
- (let* ((files (missing-files (topologically-sorted store files)))
- (pipe (remote-pipe machine OPEN_WRITE
- '("gzip" "-dc" "|"
- "guix" "archive" "--import")
- #:quote? #f)))
- (format #t (_ "sending ~a store files to '~a'...~%")
- (length files) (build-machine-name machine))
- (call-with-compressed-output-port 'gzip pipe
- (lambda (compressed)
- (catch 'system-error
- (lambda ()
- (export-paths store files compressed))
- (lambda args
- (warning (_ "failed while exporting files to '~a': ~a~%")
- (build-machine-name machine)
- (strerror (system-error-errno args))))))
- #:options '("--fast"))
-
- ;; Wait for the 'lsh' process to complete.
- (zero? (close-pipe pipe))))))
-
-(define (retrieve-files files machine)
- "Retrieve FILES from MACHINE's store, and import them."
- (define host
- (build-machine-name machine))
-
- (let ((pipe (remote-pipe machine OPEN_READ
- `("guix" "archive" "--export" ,@files
- "|" "xz" "-c")
- #:quote? #f)))
- (and pipe
- (with-store store
- (guard (c ((nix-protocol-error? c)
- (warning (_ "failed to import files from '~a': ~s~%")
- host c)
- #f))
- (format (current-error-port) "retrieving ~a files from '~a'...~%"
- (length files) host)
-
- ;; We cannot use the 'import-paths' RPC here because we already
- ;; hold the locks for FILES.
- (call-with-decompressed-port 'xz pipe
- (lambda (decompressed)
- (restore-file-set decompressed
- #:log-port (current-error-port)
- #:lock? #f)))
-
- ;; Wait for the 'lsh' process to complete.
- (zero? (close-pipe pipe)))))))
+ ;; Compute the subset of FILES missing on SESSION, and send them in
+ ;; topologically sorted order so that they can actually be imported.
+ (let* ((sorted (topologically-sorted store 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))
+
+ (with-store store
+ (remove (cut valid-path? store <>)
+ ',sorted)))))
+ (port (store-import-channel session)))
+ (format #t (_ "sending ~a store files to '~a'...~%")
+ (length missing) (session-get session 'host))
+
+ (export-paths store missing port)
+
+ ;; Tell the remote process that we're done. (In theory the
+ ;; end-of-archive mark of 'export-paths' would be enough, but in
+ ;; practice it's not.)
+ (channel-send-eof port)
+
+ ;; Wait for completion of the remote process.
+ (let ((result (zero? (channel-get-exit-status port))))
+ (close-port port)
+ result))))
+
+(define (retrieve-files files remote)
+ "Retrieve FILES from SESSION's store, and import them."
+ (let* ((session (channel-get-session (nix-server-socket remote)))
+ (host (session-get session 'host))
+ (port (store-export-channel session files)))
+ (format #t (_ "retrieving ~a files from '~a'...~%")
+ (length files) host)
+
+ ;; We cannot use the 'import-paths' RPC here because we already
+ ;; hold the locks for FILES.
+ (let ((result (restore-file-set port
+ #:log-port (current-error-port)
+ #:lock? #f)))
+ (close-port port)
+ result)))
;;;
@@ -547,13 +490,12 @@ success, #f otherwise."
(define (machine-load machine)
"Return the load of MACHINE, divided by the number of parallel builds
allowed on MACHINE."
- (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg")))
- (line (read-line pipe))
- (status (close-pipe pipe)))
- (unless (eqv? 0 (status:exit-val status))
- (warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%")
- (build-machine-name machine)
- (status:exit-val status)))
+ ;; Note: This procedure is costly since it creates a new SSH session.
+ (let* ((session (open-ssh-session machine))
+ (pipe (open-remote-pipe* session OPEN_READ
+ "cat" "/proc/loadavg"))
+ (line (read-line pipe)))
+ (close-port pipe)
(if (eof-object? line)
+inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
@@ -569,17 +511,6 @@ allowed on MACHINE."
(_
+inf.0))))) ;something's fishy about MACHINE, so avoid it
-(define (machine-power-factor m)
- "Return a factor that aggregates the speed and load of M. The higher the
-better."
- (/ (build-machine-speed m)
- (+ 1 (machine-load m))))
-
-(define (machine-less-loaded-or-faster? m1 m2)
- "Return #t if M1 is either less loaded or faster than M2. (This relation
-defines a total order on machines.)"
- (> (machine-power-factor m1) (machine-power-factor m2)))
-
(define (machine-lock-file machine hint)
"Return the name of MACHINE's lock file for HINT."
(string-append %state-directory "/offload/"
@@ -607,29 +538,39 @@ defines a total order on machines.)"
;; 5. Release the global machine-choice lock.
(with-file-lock (machine-choice-lock-file)
- (define machines+slots
+ (define machines+slots+loads
(filter-map (lambda (machine)
+ ;; Call 'machine-load' from here to make sure it is called
+ ;; only once per machine (it is expensive).
(let ((slot (acquire-build-slot machine)))
- (and slot (list machine slot))))
+ (and slot
+ (list machine slot (machine-load machine)))))
machines))
(define (undecorate pred)
(lambda (a b)
(match a
- ((machine1 slot1)
+ ((machine1 slot1 load1)
(match b
- ((machine2 slot2)
- (pred machine1 machine2)))))))
-
- (let loop ((machines+slots
- (sort machines+slots
+ ((machine2 slot2 load2)
+ (pred machine1 load1 machine2 load2)))))))
+
+ (define (machine-less-loaded-or-faster? m1 l1 m2 l2)
+ ;; Return #t if M1 is either less loaded or faster than M2, with L1
+ ;; being the load of M1 and L2 the load of M2. (This relation defines a
+ ;; total order on machines.)
+ (> (/ (build-machine-speed m1) (+ 1 l1))
+ (/ (build-machine-speed m2) (+ 1 l2))))
+
+ (let loop ((machines+slots+loads
+ (sort machines+slots+loads
(undecorate machine-less-loaded-or-faster?))))
- (match machines+slots
- (((best slot) others ...)
+ (match machines+slots+loads
+ (((best slot load) others ...)
;; Return the best machine unless it's already overloaded.
- (if (< (machine-load best) 2.)
+ (if (< load 2.)
(match others
- (((machines slots) ...)
+ (((machines slots loads) ...)
;; Release slots from the uninteresting machines.
(for-each release-build-slot slots)
@@ -675,17 +616,6 @@ defines a total order on machines.)"
;; Not now, all the machines are busy.
(display "# postpone\n")))))))
-(define-syntax-rule (with-nar-error-handling body ...)
- "Execute BODY with any &nar-error suitably reported to the user."
- (guard (c ((nar-error? c)
- (let ((file (nar-error-file c)))
- (if (condition-has-type? c &message)
- (leave (_ "while importing file '~a': ~a~%")
- file (gettext (condition-message c)))
- (leave (_ "failed to import file '~a'~%")
- file)))))
- body ...))
-
;;;
;;; Entry point.
@@ -716,7 +646,7 @@ defines a total order on machines.)"
(cond ((regexp-exec request-line-rx line)
=>
(lambda (match)
- (with-nar-error-handling
+ (with-error-handling
(process-request (equal? (match:substring match 1) "1")
(match:substring match 2) ; system
(call-with-input-file
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index b81c69f9fe..ed28ed5fcb 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -208,7 +208,7 @@ unavailable optional dependencies such as Guile-JSON."
((guix import gem) => %gem-updater)
((guix import github) => %github-updater)))
-(define (lookup-updater name)
+(define (lookup-updater-by-name name)
"Return the updater called NAME."
(or (find (lambda (updater)
(eq? name (upstream-updater-name updater)))
@@ -225,31 +225,60 @@ unavailable optional dependencies such as Guile-JSON."
%updaters)
(exit 0))
+(define (warn-no-updater package)
+ (format (current-error-port)
+ (_ "~a: warning: no updater for ~a~%")
+ (location->string (package-location package))
+ (package-name package)))
+
(define* (update-package store package updaters
- #:key (key-download 'interactive))
+ #:key (key-download 'interactive) warn?)
"Update the source file that defines PACKAGE with the new version.
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
-values: 'interactive' (default), 'always', and 'never'."
- (let-values (((version tarball)
- (package-update store package updaters
- #:key-download key-download))
- ((loc)
- (or (package-field-location package 'version)
- (package-location package))))
- (when version
- (if (and=> tarball file-exists?)
- (begin
- (format (current-error-port)
- (_ "~a: ~a: updating from version ~a to version ~a...~%")
- (location->string loc)
- (package-name package)
- (package-version package) version)
- (let ((hash (call-with-input-file tarball
- port-sha256)))
- (update-package-source package version hash)))
- (warning (_ "~a: version ~a could not be \
+values: 'interactive' (default), 'always', and 'never'. When WARN? is true,
+warn about packages that have no matching updater."
+ (if (lookup-updater package updaters)
+ (let-values (((version tarball)
+ (package-update store package updaters
+ #:key-download key-download))
+ ((loc)
+ (or (package-field-location package 'version)
+ (package-location package))))
+ (when version
+ (if (and=> tarball file-exists?)
+ (begin
+ (format (current-error-port)
+ (_ "~a: ~a: updating from version ~a to version ~a...~%")
+ (location->string loc)
+ (package-name package)
+ (package-version package) version)
+ (let ((hash (call-with-input-file tarball
+ port-sha256)))
+ (update-package-source package version hash)))
+ (warning (_ "~a: version ~a could not be \
downloaded and authenticated; not updating~%")
- (package-name package) version)))))
+ (package-name package) version))))
+ (when warn?
+ (warn-no-updater package))))
+
+(define* (check-for-package-update package #:key warn?)
+ "Check whether an update is available for PACKAGE and print a message. When
+WARN? is true and no updater exists for PACKAGE, print a warning."
+ (match (package-latest-release package %updaters)
+ ((? upstream-source? source)
+ (when (version>? (upstream-source-version source)
+ (package-version package))
+ (let ((loc (or (package-field-location package 'version)
+ (package-location package))))
+ (format (current-error-port)
+ (_ "~a: ~a would be upgraded from ~a to ~a~%")
+ (location->string loc)
+ (package-name package) (package-version package)
+ (upstream-source-version source)))))
+ (#f
+ (when warn?
+ (warn-no-updater package)))))
+
;;;
@@ -312,7 +341,7 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
;; Return the list of updaters to use.
(match (filter-map (match-lambda
(('updaters . names)
- (map lookup-updater names))
+ (map lookup-updater-by-name names))
(_ #f))
opts)
(()
@@ -360,6 +389,12 @@ update would trigger a complete rebuild."
(updaters (options->updaters opts))
(list-dependent? (assoc-ref opts 'list-dependent?))
(key-download (assoc-ref opts 'key-download))
+
+ ;; Warn about missing updaters when a package is explicitly given on
+ ;; the command line.
+ (warn? (or (assoc-ref opts 'argument)
+ (assoc-ref opts 'expression)))
+
(packages
(match (filter-map (match-lambda
(('argument . spec)
@@ -397,22 +432,13 @@ update would trigger a complete rebuild."
(%gpg-command))))
(for-each
(cut update-package store <> updaters
- #:key-download key-download)
+ #:key-download key-download
+ #:warn? warn?)
packages)
(with-monad %store-monad
(return #t))))
(else
- (for-each (lambda (package)
- (match (package-update-path package updaters)
- ((? upstream-source? source)
- (let ((loc (or (package-field-location package 'version)
- (package-location package))))
- (format (current-error-port)
- (_ "~a: ~a would be upgraded from ~a to ~a~%")
- (location->string loc)
- (package-name package) (package-version package)
- (upstream-source-version source))))
- (#f #f)))
+ (for-each (cut check-for-package-update <> #:warn? warn?)
packages)
(with-monad %store-monad
(return #t)))))))))
diff --git a/guix/store.scm b/guix/store.scm
index 7f54b87db1..689a94c636 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -345,50 +345,58 @@
(message nix-protocol-error-message)
(status nix-protocol-error-status))
-(define* (open-connection #:optional (file (%daemon-socket-file))
- #:key (reserve-space? #t) cpu-affinity)
- "Connect to the daemon over the Unix-domain socket at FILE. When
-RESERVE-SPACE? is true, instruct it to reserve a little bit of extra space on
-the file system so that the garbage collector can still operate, should the
-disk become full. When CPU-AFFINITY is true, it must be an integer
-corresponding to an OS-level CPU number to which the daemon's worker process
-for this connection will be pinned. Return a server object."
+(define (open-unix-domain-socket file)
+ "Connect to the Unix-domain socket at FILE and return it. Raise a
+'&nix-connection-error' upon error."
(let ((s (with-fluids ((%default-port-encoding #f))
;; This trick allows use of the `scm_c_read' optimization.
(socket PF_UNIX SOCK_STREAM 0)))
(a (make-socket-address PF_UNIX file)))
(catch 'system-error
- (cut connect s a)
+ (lambda ()
+ (connect s a)
+ s)
(lambda args
;; Translate the error to something user-friendly.
(let ((errno (system-error-errno args)))
(raise (condition (&nix-connection-error
(file file)
- (errno errno)))))))
+ (errno errno)))))))))
- (write-int %worker-magic-1 s)
- (let ((r (read-int s)))
+(define* (open-connection #:optional (file (%daemon-socket-file))
+ #:key port (reserve-space? #t) cpu-affinity)
+ "Connect to the daemon over the Unix-domain socket at FILE, or, if PORT is
+not #f, use it as the I/O port over which to communicate to a build daemon.
+
+When RESERVE-SPACE? is true, instruct it to reserve a little bit of extra
+space on the file system so that the garbage collector can still operate,
+should the disk become full. When CPU-AFFINITY is true, it must be an integer
+corresponding to an OS-level CPU number to which the daemon's worker process
+for this connection will be pinned. Return a server object."
+ (let ((port (or port (open-unix-domain-socket file))))
+ (write-int %worker-magic-1 port)
+ (let ((r (read-int port)))
(and (eqv? r %worker-magic-2)
- (let ((v (read-int s)))
+ (let ((v (read-int port)))
(and (eqv? (protocol-major %protocol-version)
(protocol-major v))
(begin
- (write-int %protocol-version s)
+ (write-int %protocol-version port)
(when (>= (protocol-minor v) 14)
- (write-int (if cpu-affinity 1 0) s)
+ (write-int (if cpu-affinity 1 0) port)
(when cpu-affinity
- (write-int cpu-affinity s)))
+ (write-int cpu-affinity port)))
(when (>= (protocol-minor v) 11)
- (write-int (if reserve-space? 1 0) s))
- (let ((s (%make-nix-server s
- (protocol-major v)
- (protocol-minor v)
- (make-hash-table 100)
- (make-hash-table 100))))
- (let loop ((done? (process-stderr s)))
- (or done? (process-stderr s)))
- s))))))))
+ (write-int (if reserve-space? 1 0) port))
+ (let ((conn (%make-nix-server port
+ (protocol-major v)
+ (protocol-minor v)
+ (make-hash-table 100)
+ (make-hash-table 100))))
+ (let loop ((done? (process-stderr conn)))
+ (or done? (process-stderr conn)))
+ conn))))))))
(define (close-connection server)
"Close the connection to SERVER."
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 18157376d2..08992dc19e 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -49,8 +49,11 @@
upstream-updater-predicate
upstream-updater-latest
+ lookup-updater
+
download-tarball
- package-update-path
+ package-latest-release
+ package-latest-release*
package-update
update-package-source))
@@ -127,17 +130,24 @@ them matches."
(and (pred package) latest)))
updaters))
-(define (package-update-path package updaters)
+(define (package-latest-release package updaters)
"Return an upstream source to update PACKAGE, a <package> object, or #f if
-no update is needed or known."
+none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure
+that the returned source is newer than the current one."
(match (lookup-updater package updaters)
((? procedure? latest-release)
- (match (latest-release package)
- ((and source ($ <upstream-source> name version))
- (and (version>? version (package-version package))
- source))
- (_ #f)))
- (#f #f)))
+ (latest-release package))
+ (_ #f)))
+
+(define (package-latest-release* package updaters)
+ "Like 'package-latest-release', but ensure that the return source is newer
+than that of PACKAGE."
+ (match (package-latest-release package updaters)
+ ((and source ($ <upstream-source> name version))
+ (and (version>? version (package-version package))
+ source))
+ (_
+ #f)))
(define* (download-tarball store url signature-url
#:key (key-download 'interactive))
@@ -179,7 +189,7 @@ values: the item from LST1 and the item from LST2 that match PRED."
PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
and 'interactive' (default)."
- (match (package-update-path package updaters)
+ (match (package-latest-release* package updaters)
(($ <upstream-source> _ version urls signature-urls)
(let*-values (((name)
(package-name package))