diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/trivial.scm | 2 | ||||
| -rw-r--r-- | guix/build/download.scm | 4 | ||||
| -rw-r--r-- | guix/derivations.scm | 5 | ||||
| -rw-r--r-- | guix/download.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 6 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 100 | ||||
| -rw-r--r-- | guix/store.scm | 26 |
8 files changed, 141 insertions, 19 deletions
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index af54f51419..85a3c697e3 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -54,7 +54,7 @@ ignored." search-paths native-search-paths) "Like `trivial-build', but in a cross-compilation context." (build-expression->derivation store name system - `(begin (define %target ,target) ,builder) + `(let ((%target ,target)) ,builder) (append native-inputs inputs) #:outputs outputs #:modules modules diff --git a/guix/build/download.scm b/guix/build/download.scm index 53e6b2363c..dcce0bfc89 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -28,7 +28,9 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:export (url-fetch)) + #:export (url-fetch + progress-proc + uri-abbreviation)) ;;; Commentary: ;;; diff --git a/guix/derivations.scm b/guix/derivations.scm index cf329819c4..3c433a2685 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -469,8 +469,9 @@ in SIZE bytes." (drv (make-derivation outputs inputs sources system builder args env-vars))) (sha256 - (string->utf8 (call-with-output-string - (cut write-derivation drv <>)))))))))) + (with-fluids ((%default-port-encoding "UTF-8")) + (string->utf8 (call-with-output-string + (cut write-derivation drv <>))))))))))) (define (store-path type hash name) ; makeStorePath "Return the store path for NAME/HASH/TYPE." diff --git a/guix/download.scm b/guix/download.scm index 99353be8b0..fc6c815792 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -148,7 +148,14 @@ "ftp://ftp.osuosl.org/pub/CPAN/" "ftp://ftp.nara.wide.ad.jp/pub/CPAN/" "http://mirrors.163.com/cpan/" - "ftp://cpan.mirror.ac.za/")))) + "ftp://cpan.mirror.ac.za/") + (imagemagick ; from http://www.imagemagick.org/script/download.php + "http://mirror.checkdomain.de/imagemagick/" + "ftp://gd.tuwien.ac.at/pub/graphics/ImageMagick/" + "http://www.imagemagick.org/download" + "ftp://mirror.searchdaimon.com/ImageMagick" + "http://mirror.is.co.za/pub/imagemagick/" + "ftp://mirror.aarnet.edu.au/pub/imagemagick/")))) (define (gnutls-derivation store system) "Return the GnuTLS derivation for SYSTEM." diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index cecb68ec36..77ec7635de 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -51,6 +51,8 @@ Invoke the garbage collector.\n")) (display (_ " --references list the references of PATHS")) (display (_ " + -R, --requisites list the requisites of PATHS")) + (display (_ " --referrers list the referrers of PATHS")) (newline) (display (_ " @@ -128,6 +130,10 @@ interpreted." (lambda (opt name arg result) (alist-cons 'action 'list-references (alist-delete 'action result)))) + (option '(#\R "requisites") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-requisites + (alist-delete 'action result)))) (option '("referrers") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-referrers @@ -189,6 +195,8 @@ interpreted." (delete-paths store paths)) ((list-references) (list-relatives references)) + ((list-requisites) + (list-relatives requisites)) ((list-referrers) (list-relatives referrers)) ((list-dead) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 69b7efd154..11301ccff2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -846,9 +846,13 @@ more information.~%")) (current-error-port) (%make-void-port "w")))) (build-derivations (%store) (list prof-drv))) - (begin + (let ((count (length packages))) (switch-symlinks name prof) (switch-symlinks profile name) + (format #t (N_ "~a package in profile~%" + "~a packages in profile~%" + count) + count) (display-search-paths packages profile)))))))))) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 13c382877b..271a22541a 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -24,12 +24,15 @@ #:use-module (guix records) #:use-module (guix nar) #:use-module ((guix build utils) #:select (mkdir-p)) + #:use-module ((guix build download) + #:select (progress-proc uri-abbreviation)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (ice-9 format) #:use-module (ice-9 ftw) + #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) @@ -117,7 +120,38 @@ pairs." (else (error "unmatched line" line))))) -(define* (fetch uri #:key (buffered? #t)) +(define %fetch-timeout + ;; Number of seconds after which networking is considered "slow". + 3) + +(define-syntax-rule (with-timeout duration handler body ...) + "Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY +again." + (begin + (sigaction SIGALRM + (lambda (signum) + (sigaction SIGALRM SIG_DFL) + handler)) + (alarm duration) + (call-with-values + (lambda () + (let try () + (catch 'system-error + (lambda () + body ...) + (lambda args + ;; The SIGALRM triggers EINTR. When that happens, try again. + ;; Note: SA_RESTART cannot be used because of + ;; <http://bugs.gnu.org/14640>. + (if (= EINTR (system-error-errno args)) + (try) + (apply throw args)))))) + (lambda result + (alarm 0) + (sigaction SIGALRM SIG_DFL) + (apply values result))))) + +(define* (fetch uri #:key (buffered? #t) (timeout? #t)) "Return a binary input port to URI and the number of bytes it's expected to provide." (case (uri-scheme uri) @@ -127,7 +161,21 @@ provide." (setvbuf port _IONBF)) (values port (stat:size (stat port))))) ((http) - (http-fetch uri #:text? #f #:buffered? buffered?)))) + ;; 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 + (with-timeout (if (or timeout? (version>? (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~%"))) + (http-fetch uri #:text? #f #:buffered? buffered?))))) (define-record-type <cache> (%make-cache url store-directory wants-mass-query?) @@ -353,7 +401,8 @@ indefinitely." (cute write (time-second now) <>)))) (define (decompressed-port compression input) - "Return an input port where INPUT is decompressed according to COMPRESSION." + "Return an input port where INPUT is decompressed according to COMPRESSION, +along with a list of PIDs to wait for." (match compression ("none" (values input '())) ("bzip2" (filtered-port `(,%bzip2 "-dc") input)) @@ -361,6 +410,24 @@ indefinitely." ("gzip" (filtered-port `(,%gzip "-dc") input)) (else (error "unsupported compression scheme" compression)))) +(define (progress-report-port report-progress port) + "Return a port that calls REPORT-PROGRESS every time something is read from +PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by +`progress-proc'." + (define total 0) + (define (read! bv start count) + (let ((n (match (get-bytevector-n! port bv start count) + ((? eof-object?) 0) + (x x)))) + (set! total (+ total n)) + (report-progress total (const n)) + ;; XXX: We're not in control, so we always return anyway. + n)) + + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (cut close-port port))) + (define %cache-url (or (getenv "GUIX_BINARY_SUBSTITUTE_URL") "http://hydra.gnu.org")) @@ -442,19 +509,25 @@ indefinitely." ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) + (format (current-error-port) "downloading `~a' from `~a'...~%" + store-path (uri->string uri)) (let*-values (((raw download-size) - (fetch uri #:buffered? #f)) + ;; Note that Hydra currently generates Nars on the fly + ;; and doesn't specify a Content-Length, so + ;; DOWNLOAD-SIZE is #f in practice. + (fetch uri #:buffered? #f #:timeout? #f)) + ((progress) + (let* ((comp (narinfo-compression narinfo)) + (dl-size (or download-size + (and (equal? comp "none") + (narinfo-size narinfo)))) + (progress (progress-proc (uri-abbreviation uri) + dl-size + (current-error-port)))) + (progress-report-port progress raw))) ((input pids) (decompressed-port (narinfo-compression narinfo) - raw))) - ;; Note that Hydra currently generates Nars on the fly and doesn't - ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice. - (format (current-error-port) - (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%") - store-path (uri->string uri) - download-size - (and=> download-size (cut / <> 1024.0))) - + progress))) ;; Unpack the Nar at INPUT into DESTINATION. (restore-file input destination) (every (compose zero? cdr waitpid) pids)))) @@ -464,6 +537,7 @@ indefinitely." ;;; Local Variable: ;;; eval: (put 'with-atomic-file-output 'scheme-indent-function 1) +;;; eval: (put 'with-timeout 'scheme-indent-function 1) ;;; End: ;;; substitute-binary.scm ends here diff --git a/guix/store.scm b/guix/store.scm index d15ba1275f..57e1ca06aa 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -31,6 +31,7 @@ #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) #:export (%daemon-socket-file nix-server? @@ -70,6 +71,7 @@ substitutable-path-info references + requisites referrers valid-derivers query-derivation-outputs @@ -493,6 +495,30 @@ file name. Return #t on success." "Return the list of references of PATH." store-path-list)) +(define* (fold-path store proc seed path + #:optional (relatives (cut references store <>))) + "Call PROC for each of the RELATIVES of PATH, exactly once, and return the +result formed from the successive calls to PROC, the first of which is passed +SEED." + (let loop ((paths (list path)) + (result seed) + (seen vlist-null)) + (match paths + ((path rest ...) + (if (vhash-assoc path seen) + (loop rest result seen) + (let ((seen (vhash-cons path #t seen)) + (rest (append rest (relatives path))) + (result (proc path result))) + (loop rest result seen)))) + (() + result)))) + +(define (requisites store path) + "Return the requisites of PATH, including PATH---i.e., its closure (all its +references, recursively)." + (fold-path store cons '() path)) + (define referrers (operation (query-referrers (store-path path)) "Return the list of path that refer to PATH." |