diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/linux-initrd.scm | 8 | ||||
| -rw-r--r-- | guix/config.scm.in | 2 | ||||
| -rw-r--r-- | guix/download.scm | 6 | ||||
| -rw-r--r-- | guix/git-download.scm | 3 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 9 | ||||
| -rw-r--r-- | guix/http-client.scm | 35 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 58 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 365 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 212 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 60 | ||||
| -rw-r--r-- | guix/serialization.scm | 12 | ||||
| -rw-r--r-- | guix/store.scm | 25 | ||||
| -rw-r--r-- | guix/utils.scm | 35 |
14 files changed, 564 insertions, 269 deletions
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index 80ce679496..9a8ea0ed4f 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -114,6 +114,14 @@ (device-number 4 n)) (loop (+ 1 n))))) + ;; Pseudo ttys. + (mknod (scope "dev/ptmx") 'char-special #o666 + (device-number 5 2)) + + (unless (file-exists? (scope "dev/pts")) + (mkdir (scope "dev/pts"))) + (mount "none" (scope "dev/pts") "devpts") + ;; Rendez-vous point for syslogd. (mknod (scope "dev/log") 'socket #o666 0) (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11)) diff --git a/guix/config.scm.in b/guix/config.scm.in index 5edb4ced30..eaadae9618 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -57,7 +57,7 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `daemon.am'. - (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/nix")) + (or (getenv "NIX_STATE_DIR") "@guix_localstatedir@/guix")) (define %config-directory ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'. diff --git a/guix/download.scm b/guix/download.scm index 2cc8a4a5b8..0889928d3a 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -242,7 +242,11 @@ must be a list of symbol/URL-list pairs." (guix build utils) (guix ftp-client)) #:guile-for-build guile-for-build - #:env-vars env-vars))) + #:env-vars env-vars + + ;; In general, offloading downloads is not a + ;; good idea. + #:local-build? #t))) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port))) diff --git a/guix/git-download.scm b/guix/git-download.scm index 472bf756ce..5e0a6a21dc 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -84,6 +84,7 @@ type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #:recursive? #t #:modules '((guix build git) (guix build utils)) - #:guile-for-build guile-for-build))) + #:guile-for-build guile-for-build + #:local-build? #t))) ;;; git-download.scm ends here diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 98432a69ce..14195da7ba 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -275,6 +275,10 @@ open (resp. close) FTP connections; this can be useful to reuse connections." (define contains-digit? (cut string-any char-set:digit <>)) + (define patch-directory-name? + ;; Return #t for patch directory names such as 'bash-4.2-patches'. + (cut string-suffix? "patches" <>)) + (let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server)) @@ -284,6 +288,9 @@ open (resp. close) FTP connections; this can be useful to reuse connections." ;; Filter out sub-directories that do not contain digits---e.g., ;; /gnuzilla/lang and /gnupg/patches. (subdirs (filter-map (match-lambda + (((? patch-directory-name? dir) + 'directory . _) + #f) (((? contains-digit? dir) 'directory . _) dir) (_ #f)) diff --git a/guix/http-client.scm b/guix/http-client.scm index 11231cbc1e..1f05df4b05 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012 Free Software Foundation, Inc. ;;; ;;; This file is part of GNU Guix. @@ -23,19 +23,36 @@ #:use-module (web client) #:use-module (web response) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (guix ui) #:use-module (guix utils) - #:export (open-socket-for-uri + #:export (&http-get-error + http-get-error? + http-get-error-uri + http-get-error-code + http-get-error-reason + + open-socket-for-uri http-fetch)) ;;; Commentary: ;;; -;;; HTTP client portable among Guile versions. +;;; HTTP client portable among Guile versions, and with proper error condition +;;; reporting. ;;; ;;; Code: +;; HTTP GET error. +(define-condition-type &http-get-error &error + http-get-error? + (uri http-get-error-uri) ; URI + (code http-get-error-code) ; integer + (reason http-get-error-reason)) ; string + + (define-syntax when-guile<=2.0.5 (lambda (s) (syntax-case s () @@ -154,7 +171,9 @@ unbuffered." "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an -unbuffered port, suitable for use in `filtered-port'." +unbuffered port, suitable for use in `filtered-port'. + +Raise an '&http-get-error' condition if downloading fails." (let loop ((uri uri)) (let ((port (or port (open-socket-for-uri uri @@ -202,7 +221,11 @@ unbuffered port, suitable for use in `filtered-port'." (uri->string uri)) (loop uri))) (else - (error "download failed" uri code - (response-reason-phrase resp)))))))) + (raise (condition (&http-get-error + (uri uri) + (code code) + (reason (response-reason-phrase resp))) + (&message + (message "download failed")))))))))) ;;; http-client.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 4788468584..8280a821c5 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -64,6 +64,9 @@ Export/import one or more packages from/to the store.\n")) --generate-key[=PARAMETERS] generate a key pair with the given parameters")) (display (_ " + --authorize authorize imports signed by the public key on stdin")) + (newline) + (display (_ " -e, --expression=EXPR build the package or derivation EXPR evaluates to")) (display (_ " -S, --source build the packages' source derivations")) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4a00505022..618015e9ba 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -127,6 +127,8 @@ options handled by 'set-build-options-from-command-line', and listed in --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) (display (_ " + --timeout=SECONDS mark the build as failed after SECONDS of activity")) + (display (_ " --verbosity=LEVEL use the given verbosity LEVEL")) (display (_ " -c, --cores=N allow the use of up to N CPU cores for the build"))) @@ -142,39 +144,57 @@ options handled by 'set-build-options-from-command-line', and listed in #:use-substitutes? (assoc-ref opts 'substitutes?) #:use-build-hook? (assoc-ref opts 'build-hook?) #:max-silent-time (assoc-ref opts 'max-silent-time) + #:timeout (assoc-ref opts 'timeout) #:verbosity (assoc-ref opts 'verbosity))) (define %standard-build-options ;; List of standard command-line options for tools that build something. (list (option '(#\K "keep-failed") #f #f - (lambda (opt name arg result) - (alist-cons 'keep-failed? #t result))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'keep-failed? #t result) + rest))) (option '("fallback") #f #f - (lambda (opt name arg result) - (alist-cons 'fallback? #t - (alist-delete 'fallback? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'fallback? #t + (alist-delete 'fallback? result)) + rest))) (option '("no-substitutes") #f #f - (lambda (opt name arg result) - (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)) + rest))) (option '("no-build-hook") #f #f - (lambda (opt name arg result) - (alist-cons 'build-hook? #f - (alist-delete 'build-hook? result)))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'build-hook? #f + (alist-delete 'build-hook? result)) + rest))) (option '("max-silent-time") #t #f - (lambda (opt name arg result) - (alist-cons 'max-silent-time (string->number* arg) - result))) + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'max-silent-time (string->number* arg) + result) + rest))) + (option '("timeout") #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'timeout (string->number* arg) result) + rest))) (option '("verbosity") #t #f - (lambda (opt name arg result) + (lambda (opt name arg result . rest) (let ((level (string->number arg))) - (alist-cons 'verbosity level - (alist-delete 'verbosity result))))) + (apply values + (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + rest)))) (option '(#\c "cores") #t #f - (lambda (opt name arg result) + (lambda (opt name arg result . rest) (let ((c (false-if-exception (string->number arg)))) (if c - (alist-cons 'cores c result) + (apply values (alist-cons 'cores c result) rest) (leave (_ "~a: not a number~%") arg))))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 00a145e5e9..4d2f78f711 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,7 +23,7 @@ #:use-module (guix derivations) #:use-module (guix nar) #:use-module (guix utils) - #:use-module ((guix build utils) #:select (which)) + #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -122,38 +122,40 @@ determined." (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -(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" "-z" - (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)))))) +;;; 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" "-z" +;; (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 (remote-pipe machine mode command) "Run COMMAND on MACHINE, assuming an lsh gateway has been set up." @@ -161,6 +163,10 @@ running lsh gateway upon success, or #f on failure." (lambda () (apply open-pipe* mode %lshg-command "-l" (build-machine-user machine) "-z" + + ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. + "-i" (build-machine-private-key machine) + (build-machine-name machine) command)) (lambda args @@ -168,9 +174,89 @@ running lsh gateway upon success, or #f on failure." %lshg-command (strerror (system-error-errno args))) #f))) + +;;; +;;; Synchronization. +;;; + +(define (lock-file file) + "Wait and acquire an exclusive lock on FILE. Return an open port." + (mkdir-p (dirname file)) + (let ((port (open-file file "w0"))) + (fcntl-flock port 'write-lock) + port)) + +(define (unlock-file lock) + "Unlock LOCK." + (fcntl-flock lock 'unlock) + (close-port lock) + #t) + +(define-syntax-rule (with-file-lock file exp ...) + "Wait to acquire a lock on FILE and evaluate EXP in that context." + (let ((port (lock-file file))) + (dynamic-wind + (lambda () + #t) + (lambda () + exp ...) + (lambda () + (unlock-file port))))) + +(define-syntax-rule (with-machine-lock machine hint exp ...) + "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that +context." + (with-file-lock (machine-lock-file machine hint) + exp ...)) + + +(define (machine-slot-file machine slot) + "Return the file name of MACHINE's file for SLOT." + ;; For each machine we have a bunch of files representing each build slot. + ;; When choosing a build machine, we attempt to get an exclusive lock on one + ;; of these; if we fail, that means all the build slots are already taken. + ;; Inspired by Nix's build-remote.pl. + (string-append (string-append %state-directory "/offload/" + (build-machine-name machine) + "/" (number->string slot)))) + +(define (acquire-build-slot machine) + "Attempt to acquire a build slot on MACHINE. Return the port representing +the slot, or #f if none is available. + +This mechanism allows us to set a hard limit on the number of simultaneous +connections allowed to MACHINE." + (mkdir-p (dirname (machine-slot-file machine 0))) + (with-machine-lock machine 'slots + (any (lambda (slot) + (let ((port (open-file (machine-slot-file machine slot) + "w0"))) + (catch 'flock-error + (lambda () + (fcntl-flock port 'write-lock #:wait? #f) + ;; Got it! + (format (current-error-port) + "process ~a acquired build slot '~a'~%" + (getpid) (port-filename port)) + port) + (lambda args + ;; PORT is already locked by another process. + (close-port port) + #f)))) + (iota (build-machine-parallel-builds machine))))) + +(define (release-build-slot slot) + "Release SLOT, a build slot as returned as by 'acquire-build-slot'." + (close-port slot)) + + +;;; +;;; Offloading. +;;; + (define* (offload drv machine #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200) (log-port (current-output-port))) + build-timeout (log-port (current-output-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'...~%" @@ -181,9 +267,12 @@ there, and write the build log to LOG-PORT. Return the exit status." ;; FIXME: Protect DRV from garbage collection on MACHINE. (let ((pipe (remote-pipe machine OPEN_READ `("guix" "build" - ;; FIXME: more options ,(format #f "--max-silent-time=~a" max-silent-time) + ,@(if build-timeout + (list (format #f "--timeout=~a" + build-timeout)) + '()) ,(derivation-file-name drv))))) (let loop ((line (read-line pipe))) (unless (eof-object? line) @@ -193,6 +282,43 @@ there, and write the build log to LOG-PORT. Return the exit status." (close-pipe pipe))) +(define* (transfer-and-offload drv machine + #:key + (inputs '()) + (outputs '()) + (max-silent-time 3600) + build-timeout + print-build-trace?) + "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." + ;; Acquire MACHINE's exclusive lock to serialize file transfers + ;; to/from MACHINE in the presence of several 'offload' hook + ;; instance. + (when (with-machine-lock machine 'bandwidth + (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 + ;; Likewise (see above.) + (with-machine-lock machine 'bandwidth + (retrieve-files outputs machine)) + (format (current-error-port) + "done with offloaded '~a'~%" + (derivation-file-name drv))) + (begin + (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)) + (primitive-exit (status:exit-val status))))))) + (define (send-files files machine) "Send the subset of FILES that's missing to MACHINE's store. Return #t on success, #f otherwise." @@ -256,6 +382,11 @@ success, #f otherwise." (zero? (close-pipe pipe))))))) + +;;; +;;; Scheduling. +;;; + (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." (and (string=? (build-requirements-system requirements) @@ -268,57 +399,124 @@ success, #f otherwise." "Return #t if M1 is faster than M2." (> (build-machine-speed m1) (build-machine-speed m2))) -(define (choose-build-machine requirements machines) - "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f." - ;; FIXME: Take machine load into account, and/or shuffle MACHINES. - (let ((machines (sort (filter (cut machine-matches? <> requirements) - machines) - machine-faster?))) - (match machines - ((head . _) - head) - (_ #f)))) +(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))) + (close-pipe pipe) + (if (eof-object? line) + 1. + (match (string-tokenize line) + ((one five fifteen . _) + (let* ((raw (string->number five)) + (jobs (build-machine-parallel-builds machine)) + (normalized (/ raw jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ + (normalized: ~s)~%" + (build-machine-name machine) raw normalized) + normalized)) + (_ + 1.))))) + +(define (machine-less-loaded? m1 m2) + "Return #t if the load on M1 is lower than that on M2." + (< (machine-load m1) (machine-load m2))) + +(define (machine-less-loaded-or-faster? m1 m2) + "Return #t if M1 is either less loaded or faster than M2." + (or (machine-less-loaded? m1 m2) + (machine-faster? m1 m2))) + +(define (machine-lock-file machine hint) + "Return the name of MACHINE's lock file for HINT." + (string-append %state-directory "/offload/" + (build-machine-name machine) + "." (symbol->string hint) ".lock")) + +(define (machine-choice-lock-file) + "Return the name of the file used as a lock when choosing a build machine." + (string-append %state-directory "/offload/machine-choice.lock")) + + +(define %slots + ;; List of acquired build slots (open ports). + '()) + +(define (choose-build-machine machines) + "Return the best machine among MACHINES, or #f." + + ;; Proceed like this: + ;; 1. Acquire the global machine-choice lock. + ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out + ;; those machines for which we failed. + ;; 3. Choose the best machine among those that are left. + ;; 4. Release the previously-acquired build slots of the other machines. + ;; 5. Release the global machine-choice lock. + + (with-file-lock (machine-choice-lock-file) + (define machines+slots + (filter-map (lambda (machine) + (let ((slot (acquire-build-slot machine))) + (and slot (list machine slot)))) + machines)) + + (define (undecorate pred) + (match-lambda + ((machine slot) + (and (pred machine) + (list machine slot))))) + + (let ((machines+slots (sort machines+slots + (undecorate machine-less-loaded-or-faster?)))) + (match machines+slots + (((best slot) (others slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; Return the best machine unless it's already overloaded. + (if (< (machine-load best) 2.) + (begin + ;; Prevent SLOT from being GC'd. + (set! %slots (cons slot %slots)) + best) + (begin + (release-build-slot slot) + #f))) + (() #f))))) (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) - (build-timeout 7200)) + build-timeout) "Process a request to build DRV." - (let* ((local? (and wants-local? (string=? system (%current-system)))) - (reqs (build-requirements - (system system) - (features features))) - (machine (choose-build-machine reqs (build-machines)))) - (if machine - (match (open-ssh-gateway machine) - ((? integer? pid) - (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) - (outputs (string-tokenize (read-line)))) - (when (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))) - (kill pid SIGTERM) - (if (zero? status) - (begin - (retrieve-files outputs machine) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (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)) - (primitive-exit (status:exit-val status)))))))) - (#f - (display "# decline\n"))) - (display "# decline\n")))) + (let* ((local? (and wants-local? (string=? system (%current-system)))) + (reqs (build-requirements + (system system) + (features features))) + (candidates (filter (cut machine-matches? <> reqs) + (build-machines)))) + (match candidates + (() + ;; We'll never be able to match REQS. + (display "# decline\n")) + ((_ ...) + (let ((machine (choose-build-machine candidates))) + (if machine + (begin + ;; Offload DRV to MACHINE. + (display "# accept\n") + (let ((inputs (string-tokenize (read-line))) + (outputs (string-tokenize (read-line)))) + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? print-build-trace?))) + + ;; 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." @@ -388,4 +586,9 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (x (leave (_ "invalid arguments: ~{~s ~}~%") x)))) +;;; Local Variables: +;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) +;;; eval: (put 'with-file-lock 'scheme-indent-function 1) +;;; End: + ;;; offload.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d41a83de8a..6069b203de 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -26,6 +26,7 @@ #:use-module (guix profiles) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix scripts build) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix ftp-client) #:select (ftp-open)) #:use-module (ice-9 format) @@ -460,6 +461,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." ;; Alist of default option values. `((profile . ,%current-profile) (max-silent-time . 3600) + (verbosity . 0) (substitutes? . #t))) (define (show-help) @@ -484,18 +486,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -d, --delete-generations[=PATTERN] delete generations matching PATTERN")) - (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) - (display (_ " - -n, --dry-run show what would be done without actually doing it")) - (display (_ " - --fallback fall back to building when the substituter fails")) - (display (_ " - --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " - --max-silent-time=SECONDS - mark the build as failed after SECONDS of silence")) + (newline) (display (_ " --bootstrap use the bootstrap Guile to build the profile")) (display (_ " @@ -510,6 +503,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) -A, --list-available[=REGEXP] list available packages matching REGEXP")) (newline) + (show-build-options-help) + (newline) (display (_ " -h, --help display this help and exit")) (display (_ " @@ -519,107 +514,94 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (define %options ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix package"))) - - (option '(#\i "install") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (if arg - (alist-cons 'install arg result) - result) - arg-handler)))) - (option '(#\e "install-from-expression") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'install (read/eval-package-expression arg) - result) - #f))) - (option '(#\r "remove") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (if arg - (alist-cons 'remove arg result) - result) - arg-handler)))) - (option '(#\u "upgrade") #f #t - (lambda (opt name arg result arg-handler) - (let arg-handler ((arg arg) (result result)) - (values (alist-cons 'upgrade arg - ;; Delete any prior "upgrade all" - ;; command, or else "--upgrade gcc" - ;; would upgrade everything. - (delete '(upgrade . #f) result)) - arg-handler)))) - (option '("roll-back") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'roll-back? #t result) - #f))) - (option '(#\l "list-generations") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-generations ,(or arg "")) - result) - #f))) - (option '(#\d "delete-generations") #f #t - (lambda (opt name arg result arg-handler) - (values (alist-cons 'delete-generations (or arg "") - result) - #f))) - (option '("search-paths") #f #f - (lambda (opt name arg result arg-handler) - (values (cons `(query search-paths) result) - #f))) - (option '(#\p "profile") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'profile arg - (alist-delete 'profile result)) - #f))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'dry-run? #t result) - #f))) - (option '("fallback") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'fallback? #t - (alist-delete 'fallback? result)) - #f))) - (option '("no-substitutes") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)) - #f))) - (option '("max-silent-time") #t #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'max-silent-time (string->number* arg) - result) - #f))) - (option '("bootstrap") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'bootstrap? #t result) - #f))) - (option '("verbose") #f #f - (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) - #f))) - (option '(#\s "search") #t #f - (lambda (opt name arg result arg-handler) - (values (cons `(query search ,(or arg "")) - result) - #f))) - (option '(#\I "list-installed") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-installed ,(or arg "")) - result) - #f))) - (option '(#\A "list-available") #f #t - (lambda (opt name arg result arg-handler) - (values (cons `(query list-available ,(or arg "")) - result) - #f))))) + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix package"))) + + (option '(#\i "install") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'install arg result) + result) + arg-handler)))) + (option '(#\e "install-from-expression") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'install (read/eval-package-expression arg) + result) + #f))) + (option '(#\r "remove") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (if arg + (alist-cons 'remove arg result) + result) + arg-handler)))) + (option '(#\u "upgrade") #f #t + (lambda (opt name arg result arg-handler) + (let arg-handler ((arg arg) (result result)) + (values (alist-cons 'upgrade arg + ;; Delete any prior "upgrade all" + ;; command, or else "--upgrade gcc" + ;; would upgrade everything. + (delete '(upgrade . #f) result)) + arg-handler)))) + (option '("roll-back") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'roll-back? #t result) + #f))) + (option '(#\l "list-generations") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-generations ,(or arg "")) + result) + #f))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result arg-handler) + (values (alist-cons 'delete-generations (or arg "") + result) + #f))) + (option '("search-paths") #f #f + (lambda (opt name arg result arg-handler) + (values (cons `(query search-paths) result) + #f))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'profile arg + (alist-delete 'profile result)) + #f))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'dry-run? #t result) + #f))) + (option '("bootstrap") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'bootstrap? #t result) + #f))) + (option '("verbose") #f #f + (lambda (opt name arg result arg-handler) + (values (alist-cons 'verbose? #t result) + #f))) + (option '(#\s "search") #t #f + (lambda (opt name arg result arg-handler) + (values (cons `(query search ,(or arg "")) + result) + #f))) + (option '(#\I "list-installed") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-installed ,(or arg "")) + result) + #f))) + (option '(#\A "list-available") #f #t + (lambda (opt name arg result arg-handler) + (values (cons `(query list-available ,(or arg "")) + result) + #f))) + + %standard-build-options)) (define (options->installable opts manifest) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', @@ -1052,13 +1034,7 @@ more information.~%")) (or (process-query opts) (with-error-handling (parameterize ((%store (open-connection))) - (set-build-options (%store) - #:print-build-trace #f - #:fallback? (assoc-ref opts 'fallback?) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:max-silent-time - (assoc-ref opts 'max-silent-time)) + (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation (%store) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 3aaa1c4284..54f4aaa6c0 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -38,6 +38,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (web uri) #:use-module (guix http-client) #:export (guix-substitute-binary)) @@ -133,33 +134,38 @@ provide." (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) ((http) - ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So - ;; honor TIMEOUT? to disable the timeout when fetching a nar. - ;; - ;; Test this with: - ;; sudo tc qdisc add dev eth0 root netem delay 1500ms - ;; and then cancel with: - ;; sudo tc qdisc del dev eth0 root - (let ((port #f)) - (with-timeout (if (or timeout? (guile-version>? "2.0.5")) - %fetch-timeout - 0) - (begin - (warning (_ "while fetching ~a: server is unresponsive~%") - (uri->string uri)) - (warning (_ "try `--no-substitutes' if the problem persists~%")) - - ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, - ;; and thus PORT had to be closed and re-opened. This is not the - ;; case afterward. - (unless (or (guile-version>? "2.0.9") - (version>? (version) "2.0.9.39")) - (when port - (close-port port)))) - (begin - (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri #:buffered? buffered?))) - (http-fetch uri #:text? #f #:port port))))))) + (guard (c ((http-get-error? c) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)))) + ;; On Guile 2.0.5, `http-fetch' fetches the whole thing at once. So + ;; honor TIMEOUT? to disable the timeout when fetching a nar. + ;; + ;; Test this with: + ;; sudo tc qdisc add dev eth0 root netem delay 1500ms + ;; and then cancel with: + ;; sudo tc qdisc del dev eth0 root + (let ((port #f)) + (with-timeout (if (or timeout? (guile-version>? "2.0.5")) + %fetch-timeout + 0) + (begin + (warning (_ "while fetching ~a: server is unresponsive~%") + (uri->string uri)) + (warning (_ "try `--no-substitutes' if the problem persists~%")) + + ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, + ;; and thus PORT had to be closed and re-opened. This is not the + ;; case afterward. + (unless (or (guile-version>? "2.0.9") + (version>? (version) "2.0.9.39")) + (when port + (close-port port)))) + (begin + (when (or (not port) (port-closed? port)) + (set! port (open-socket-for-uri uri #:buffered? buffered?))) + (http-fetch uri #:text? #f #:port port)))))))) (define-record-type <cache> (%make-cache url store-directory wants-mass-query?) diff --git a/guix/serialization.scm b/guix/serialization.scm index 474dc69de5..284b174794 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,11 +22,13 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 match) #:export (write-int read-int write-long-long read-long-long write-padding write-string read-string read-latin1-string write-string-list read-string-list + write-string-pairs write-store-path read-store-path write-store-path-list read-store-path-list)) @@ -94,6 +96,14 @@ (write-int (length l) p) (for-each (cut write-string <> p) l)) +(define (write-string-pairs l p) + (write-int (length l) p) + (for-each (match-lambda + ((first . second) + (write-string first p) + (write-string second p))) + l)) + (define (read-string-list p) (let ((len (read-int p))) (unfold (cut >= <> len) diff --git a/guix/store.scm b/guix/store.scm index 54ed31cbbc..909ef195de 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -197,7 +197,7 @@ result)))))) (define-syntax write-arg - (syntax-rules (integer boolean file string string-list + (syntax-rules (integer boolean file string string-list string-pairs store-path store-path-list base16) ((_ integer arg p) (write-int arg p)) @@ -209,6 +209,8 @@ (write-string arg p)) ((_ string-list arg p) (write-string-list arg p)) + ((_ string-pairs arg p) + (write-string-pairs arg p)) ((_ store-path arg p) (write-store-path arg p)) ((_ store-path-list arg p) @@ -430,6 +432,7 @@ encoding conversion errors." #:key keep-failed? keep-going? fallback? (verbosity 0) (max-build-jobs (current-processor-count)) + timeout (max-silent-time 3600) (use-build-hook? #t) (build-verbosity 0) @@ -462,12 +465,11 @@ encoding conversion errors." (when (>= (nix-server-minor-version server) 10) (send (boolean use-substitutes?))) (when (>= (nix-server-minor-version server) 12) - (send (string-list (fold-right (lambda (pair result) - (match pair - ((h . t) - (cons* h t result)))) - '() - binary-caches)))) + (let ((pairs (if timeout + `(("build-timeout" . ,(number->string timeout)) + ,@binary-caches) + binary-caches))) + (send (string-pairs pairs)))) (let loop ((done? (process-stderr server))) (or done? (process-stderr server))))) @@ -734,8 +736,13 @@ is raised if the set of paths read from PORT is not signed (as per (define* (export-paths server paths port #:key (sign? #t)) "Export the store paths listed in PATHS to PORT, in topological order, signing them if SIGN? is true." + (define ordered + ;; Sort PATHS, but don't include their references. + (filter (cut member <> paths) + (topologically-sorted server paths))) + (let ((s (nix-server-socket server))) - (let loop ((paths (topologically-sorted server paths))) + (let loop ((paths ordered)) (match paths (() (write-int 0 port)) @@ -822,7 +829,7 @@ must be an absolute store file name, or a derivation file name." (cond ((derivation-path? file) (let* ((base (basename file)) (log (string-append (dirname %state-directory) ; XXX - "/log/nix/drvs/" + "/log/guix/drvs/" (string-take base 2) "/" (string-drop base 2))) (log.bz2 (string-append log ".bz2"))) diff --git a/guix/utils.scm b/guix/utils.scm index 5fda2116de..68329ec915 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -244,6 +244,13 @@ buffered data is lost." ((string-contains %host-type "linux") 7) ; *-linux-gnu (else 9)))) ; *-gnu* +(define F_SETLK + ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6. + (compile-time-value + (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu + ((string-contains %host-type "linux") 6) ; *-linux-gnu + (else 8)))) ; *-gnu* + (define F_xxLCK ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants. (compile-time-value @@ -252,12 +259,30 @@ buffered data is lost." ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu (else #(1 2 3))))) ; *-gnu* +(define %libc-errno-pointer + ;; Glibc's 'errno' pointer. + (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) + (and errno-loc + (let ((proc (pointer->procedure '* errno-loc '()))) + (proc))))) + +(define (errno) + "Return the current errno." + ;; XXX: We assume that nothing changes 'errno' while we're doing all this. + ;; In particular, that means that no async must be running here. + (if %libc-errno-pointer + (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) + (bytevector-sint-ref bv 0 (native-endianness) (sizeof int))) + 0)) + (define fcntl-flock (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) (proc (pointer->procedure int ptr `(,int ,int *)))) - (lambda (fd-or-port operation) + (lambda* (fd-or-port operation #:key (wait? #t)) "Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION -must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." +must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is +true, block until the lock is acquired; otherwise, thrown an 'flock-error' +exception if it's already taken." (define (operation->int op) (case op ((read-lock) (vector-ref F_xxLCK 0)) @@ -273,7 +298,9 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." ;; XXX: 'fcntl' is a vararg function, but here we happily use the ;; standard ABI; crossing fingers. (let ((err (proc fd - F_SETLKW ; lock & wait + (if wait? + F_SETLKW ; lock & wait + F_SETLK) ; non-blocking attempt (make-c-struct %struct-flock (list (operation->int operation) SEEK_SET @@ -282,7 +309,7 @@ must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." (or (zero? err) ;; Presumably we got EAGAIN or so. - (throw 'flock-error fd)))))) + (throw 'flock-error (errno))))))) ;;; |