diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/derivations.scm | 4 | ||||
| -rw-r--r-- | guix/import/crate.scm | 4 | ||||
| -rw-r--r-- | guix/import/gem.scm | 2 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 137 | ||||
| -rw-r--r-- | guix/serialization.scm | 8 | ||||
| -rw-r--r-- | guix/ssh.scm | 146 | ||||
| -rw-r--r-- | guix/store.scm | 8 | ||||
| -rw-r--r-- | guix/ui.scm | 6 |
9 files changed, 216 insertions, 101 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 97f96d99c1..da686e89e2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -230,7 +230,7 @@ Nix itself keeps only one of them." CUT? is a predicate that is passed a derivation-input and returns true to eliminate the given input and its dependencies from the search. An example of -search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the +such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the result is the set of prerequisites of DRV not already in valid." (let loop ((drv drv) (result '()) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 233a20e983..a7485bb4d0 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -59,7 +59,9 @@ (repository (assoc-ref crate "repository")) (synopsis (assoc-ref crate "description")) (description (assoc-ref crate "description")) - (license (string->license (assoc-ref crate "license"))) + (license (or (and=> (assoc-ref crate "license") + string->license) + '())) ;missing license info (path (string-append "/" version "/dependencies")) (deps-json (json-fetch (string-append crate-url name path))) (deps (assoc-ref deps-json "dependencies")) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 3ad7facc7f..6e914d6290 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copryight © 2016 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 2c9df073d3..4fb00af404 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org> -;;; Coypright © 2016 ng0 <ng0@we.make.ritual.n0.is> +;;; Copyright © 2016 ng0 <ng0@we.make.ritual.n0.is> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index dd54f03996..1673fb9f33 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -326,7 +326,7 @@ advertise it as the maximum validity period (in seconds) via the appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) - (not-found request) + (not-found request #:phrase "") (values `((content-type . (application/x-nix-narinfo)) ,@(if ttl `((cache-control (max-age . ,ttl))) @@ -461,7 +461,7 @@ requested using POOL." #:phrase "We're baking it" #:ttl 300)) ;should be available within 5m (else - (not-found request))))) + (not-found request #:phrase ""))))) (define* (bake-narinfo+nar cache item #:key ttl (compression %no-compression) @@ -505,10 +505,10 @@ requested using POOL." stat:size)) port)))))) -;; XXX: Declare the 'Guix-Compression' HTTP header, which is in fact for +;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. -(declare-header! "Guix-Nar-Compression" +(declare-header! "X-Nar-Compression" (lambda (str) (match (call-with-input-string str read) (('compression type level) @@ -529,7 +529,7 @@ requested using POOL." (if (valid-path? store store-path) (values `((content-type . (application/x-nix-archive (charset . "ISO-8859-1"))) - (guix-nar-compression . ,compression)) + (x-nar-compression . ,compression)) ;; XXX: We're not returning the actual contents, deferring ;; instead to 'http-write'. This is a hack to work around ;; <http://bugs.gnu.org/21093>. @@ -544,11 +544,12 @@ return it; otherwise, return 404." #:compression compression))) (if (file-exists? cached) (values `((content-type . (application/octet-stream - (charset . "ISO-8859-1")))) - ;; XXX: We're not returning the actual contents, deferring - ;; instead to 'http-write'. This is a hack to work around - ;; <http://bugs.gnu.org/21093>. - cached) + (charset . "ISO-8859-1"))) + ;; XXX: We're not returning the actual contents, deferring + ;; instead to 'http-write'. This is a hack to work around + ;; <http://bugs.gnu.org/21093>. + (x-raw-file . ,cached)) + #f) (not-found request)))) (define (render-content-addressed-file store request @@ -562,14 +563,40 @@ has the given HASH of type ALGO." #:recursive? #f))) (if (valid-path? store item) (values `((content-type . (application/octet-stream - (charset . "ISO-8859-1")))) - ;; XXX: We're not returning the actual contents, deferring - ;; instead to 'http-write'. This is a hack to work around - ;; <http://bugs.gnu.org/21093>. - item) + (charset . "ISO-8859-1"))) + ;; XXX: We're not returning the actual contents, + ;; deferring instead to 'http-write'. This is a hack to + ;; work around <http://bugs.gnu.org/21093>. + (x-raw-file . ,item)) + #f) (not-found request))) (not-found request))) +(define (render-log-file store request name) + "Render the log file for NAME, the base name of a store item. Don't attempt +to compress or decompress the log file; just return it as-is." + (define (response-headers file) + ;; XXX: We're not returning the actual contents, deferring instead to + ;; 'http-write'. This is a hack to work around + ;; <http://bugs.gnu.org/21093>. + (cond ((string-suffix? ".gz" file) + `((content-type . (text/plain (charset . "UTF-8"))) + (content-encoding . (gzip)) + (x-raw-file . ,file))) + ((string-suffix? ".bz2" file) + `((content-type . (application/x-bzip2 + (charset . "ISO-8859-1"))) + (x-raw-file . ,file))) + (else ;uncompressed + `((content-type . (text/plain (charset . "UTF-8"))) + (x-raw-file . ,file))))) + + (let ((log (log-file store + (string-append (%store-prefix) "/" name)))) + (if log + (values (response-headers log) log) + (not-found request)))) + (define (render-home-page request) "Render the home page." (values `((content-type . (text/html (charset . "UTF-8")))) @@ -611,20 +638,22 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define %http-write (@@ (web server http) http-write)) +(define (strip-headers response) + "Return RESPONSE's headers minus 'Content-Length' and our internal headers." + (fold alist-delete + (response-headers response) + '(content-length x-raw-file x-nar-compression))) + (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." (set-field response (response-headers) - (alist-delete 'content-length - (response-headers response) - eq?))) + (strip-headers response))) (define (with-content-length response length) "Return RESPONSE with a 'content-length' header set to LENGTH." (set-field response (response-headers) (alist-cons 'content-length length - (alist-delete 'content-length - (response-headers response) - eq?)))) + (strip-headers response)))) (define-syntax-rule (swallow-EPIPE exp ...) "Swallow EPIPE errors raised by EXP..." @@ -646,7 +675,7 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." (define (nar-response-port response) "Return a port on which to write the body of RESPONSE, the response of a /nar request, according to COMPRESSION." - (match (assoc-ref (response-headers response) 'guix-nar-compression) + (match (assoc-ref (response-headers response) 'x-nar-compression) (($ <compression> 'gzip level) ;; Note: We cannot used chunked encoding here because ;; 'make-gzip-output-port' wants a file port. @@ -685,35 +714,37 @@ blocking." (swallow-zlib-error (close-port port)) (values))))) - (('application/octet-stream . _) - ;; Send a raw file in a separate thread. - (call-with-new-thread - (lambda () - (set-thread-name "publish file") - (catch 'system-error - (lambda () - (call-with-input-file (utf8->string body) - (lambda (input) - (let* ((size (stat:size (stat input))) - (response (write-response (with-content-length response - size) - client)) - (output (response-port response))) - (if (file-port? output) - (sendfile output input size) - (dump-port input output)) - (close-port output) - (values))))) - (lambda args - ;; If the file was GC'd behind our back, that's fine. Likewise if - ;; the client closes the connection. - (unless (memv (system-error-errno args) - (list ENOENT EPIPE ECONNRESET)) - (apply throw args)) - (values)))))) (_ - ;; Handle other responses sequentially. - (%http-write server client response body)))) + (match (assoc-ref (response-headers response) 'x-raw-file) + ((? string? file) + ;; Send a raw file in a separate thread. + (call-with-new-thread + (lambda () + (set-thread-name "publish file") + (catch 'system-error + (lambda () + (call-with-input-file file + (lambda (input) + (let* ((size (stat:size (stat input))) + (response (write-response (with-content-length response + size) + client)) + (output (response-port response))) + (if (file-port? output) + (sendfile output input size) + (dump-port input output)) + (close-port output) + (values))))) + (lambda args + ;; If the file was GC'd behind our back, that's fine. Likewise if + ;; the client closes the connection. + (unless (memv (system-error-errno args) + (list ENOENT EPIPE ECONNRESET)) + (apply throw args)) + (values)))))) + (#f + ;; Handle other responses sequentially. + (%http-write server client response body)))))) (define-server-impl concurrent-http-server ;; A variant of Guile's built-in HTTP server that offloads possibly long @@ -768,6 +799,10 @@ blocking." (render-content-addressed-file store request name 'sha256 hash)))) + ;; /log/OUTPUT + (("log" name) + (render-log-file store request name)) + ;; Use different URLs depending on the compression type. This ;; guarantees that /nar URLs remain valid even when 'guix publish' ;; is restarted with different compression parameters. diff --git a/guix/serialization.scm b/guix/serialization.scm index e6ae2fc307..b41a0a09d1 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -102,9 +102,9 @@ (or (zero? m) (put-bytevector p zero 0 (- 8 m))))))) -(define (write-bytevector s p) - (let* ((l (bytevector-length s)) - (m (modulo l 8)) +(define* (write-bytevector s p + #:optional (l (bytevector-length s))) + (let* ((m (modulo l 8)) (b (make-bytevector (+ 8 l (if (zero? m) 0 (- 8 m)))))) (bytevector-u32-set! b 0 l (endianness little)) (bytevector-copy! s 0 b 8 l) diff --git a/guix/ssh.scm b/guix/ssh.scm index 7b33ef5a3b..cb560c0e9c 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -19,6 +19,7 @@ (define-module (guix ssh) #:use-module (guix store) #:use-module (guix i18n) + #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ssh session) #:use-module (ssh auth) #:use-module (ssh key) @@ -100,30 +101,43 @@ Throw an error on failure." ;; Unix-domain sockets but libssh doesn't have an API for that, hence this ;; hack. `(begin - (use-modules (ice-9 match) (rnrs io ports)) + (use-modules (ice-9 match) (rnrs io ports) + (rnrs bytevectors) (system foreign)) + + (define read! + ;; XXX: We would use 'get-bytevector-some' but it always returns a + ;; single byte in Guile <= 2.2.3---see <https://bugs.gnu.org/30066>. + ;; This procedure works around it. + (let ((proc (pointer->procedure int + (dynamic-func "read" (dynamic-link)) + (list int '* size_t)))) + (lambda (port bv) + (proc (fileno port) (bytevector->pointer bv) + (bytevector-length bv))))) (let ((sock (socket AF_UNIX SOCK_STREAM 0)) (stdin (current-input-port)) - (stdout (current-output-port))) + (stdout (current-output-port)) + (buffer (make-bytevector 65536))) (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 ()) + (match (select (list stdin sock) '() '()) + ((reads () ()) (when (memq stdin reads) - (match (get-bytevector-some stdin) - ((? eof-object?) + (match (read! stdin buffer) + ((? zero?) ;EOF (primitive-exit 0)) - (bv - (put-bytevector sock bv)))) + (count + (put-bytevector sock buffer 0 count)))) (when (memq sock reads) - (match (get-bytevector-some sock) - ((? eof-object?) + (match (read! sock buffer) + ((? zero?) ;EOF (primitive-exit 0)) - (bv - (put-bytevector stdout bv)))) + (count + (put-bytevector stdout buffer 0 count)))) (loop)) (_ (primitive-exit 1))))))) @@ -197,15 +211,36 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." ;; remote store. (define export `(begin - (use-modules (guix)) - - (with-store store - (setvbuf (current-output-port) _IONBF) - - ;; FIXME: Exceptions are silently swallowed. We should report them - ;; somehow. - (export-paths store ',files (current-output-port) - #:recursive? ,recursive?)))) + (eval-when (load expand eval) + (unless (resolve-module '(guix) #:ensure #f) + (write `(module-error)) + (exit 7))) + + (use-modules (guix) (srfi srfi-1) + (srfi srfi-26) (srfi srfi-34)) + + (guard (c ((nix-connection-error? c) + (write `(connection-error ,(nix-connection-error-file c) + ,(nix-connection-error-code c)))) + ((nix-protocol-error? c) + (write `(protocol-error ,(nix-protocol-error-status c) + ,(nix-protocol-error-message c)))) + (else + (write `(exception)))) + (with-store store + (let* ((files ',files) + (invalid (remove (cut valid-path? store <>) + files))) + (unless (null? invalid) + (write `(invalid-items ,invalid)) + (exit 1)) + + (write '(exporting)) ;we're ready + (force-output) + + (setvbuf (current-output-port) _IONBF) + (export-paths store files (current-output-port) + #:recursive? ,recursive?)))))) (open-remote-input-pipe session (string-join @@ -291,6 +326,19 @@ to the length of FILES.)" #:recursive? recursive?) (length files))) ;XXX: inaccurate when RECURSIVE? is true +(define-syntax raise-error + (syntax-rules (=>) + ((_ fmt args ... (=> hint-fmt hint-args ...)) + (raise (condition + (&message + (message (format #f fmt args ...))) + (&fix-hint + (hint (format #f hint-fmt hint-args ...)))))) + ((_ fmt args ...) + (raise (condition + (&message + (message (format #f fmt args ...)))))))) + (define* (retrieve-files local files remote #:key recursive? (log-port (current-error-port))) "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on @@ -298,22 +346,44 @@ LOCAL. When RECURSIVE? is true, retrieve the closure of FILES." (let-values (((port count) (file-retrieval-port files remote #:recursive? recursive?))) - (format #t (N_ "retrieving ~a store item from '~a'...~%" - "retrieving ~a store items from '~a'...~%" count) - count (remote-store-host remote)) - (when (eof-object? (lookahead-u8 port)) - ;; The failure could be because one of the requested store items is not - ;; valid on REMOTE, or because Guile or Guix is improperly installed. - ;; TODO: Improve error reporting. - (raise (condition - (&message - (message - (format #f - (G_ "failed to retrieve store items from '~a'") - (remote-store-host remote))))))) - - (let ((result (import-paths local port))) - (close-port port) - result))) + (match (read port) ;read the initial status + (('exporting) + (format #t (N_ "retrieving ~a store item from '~a'...~%" + "retrieving ~a store items from '~a'...~%" count) + count (remote-store-host remote)) + + (let ((result (import-paths local port))) + (close-port port) + result)) + ((? eof-object?) + (raise-error (G_ "failed to start Guile on remote host '~A': exit code ~A") + (remote-store-host remote) + (channel-get-exit-status port) + (=> (G_ "Make sure @command{guile} can be found in +@code{$PATH} on the remote host. Run @command{ssh ~A guile --version} to +check.") + (remote-store-host remote)))) + (('module-error . _) + ;; TRANSLATORS: Leave "Guile" untranslated. + (raise-error (G_ "Guile modules not found on remote host '~A'") + (remote-store-host remote) + (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix' +own module directory. Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to +check.") + (remote-store-host remote)))) + (('connection-error file code . _) + (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a") + file (remote-store-host remote) (strerror code))) + (('invalid-items items . _) + (raise-error (N_ "no such item on remote host '~A':~{ ~a~}" + "no such items on remote host '~A':~{ ~a~}" + (length items)) + (remote-store-host remote) items)) + (('protocol-error status message . _) + (raise-error (G_ "protocol error on remote host '~A': ~a") + (remote-store-host remote) message)) + (_ + (raise-error (G_ "failed to retrieve store items from '~a'") + (remote-store-host remote)))))) ;;; ssh.scm ends here diff --git a/guix/store.scm b/guix/store.scm index e6e45ba89c..6742611c6f 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -609,7 +609,7 @@ encoding conversion errors." (let* ((max-len (read-int p)) (data (make-bytevector max-len)) (len (get-bytevector-n! user-port data 0 max-len))) - (write-bytevector data p) + (write-bytevector data p len) #f)) ((= k %stderr-next) ;; Log a string. Build logs are usually UTF-8-encoded, but they @@ -1567,8 +1567,10 @@ must be an absolute store file name, or a derivation file name." "/log/guix/drvs/" (string-take base 2) "/" (string-drop base 2))) + (log.gz (string-append log ".gz")) (log.bz2 (string-append log ".bz2"))) - (cond ((file-exists? log.bz2) log.bz2) + (cond ((file-exists? log.gz) log.gz) + ((file-exists? log.bz2) log.bz2) ((file-exists? log) log) (else #f)))) (else diff --git a/guix/ui.scm b/guix/ui.scm index 6e08a611cd..895179744b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -623,6 +623,12 @@ directories:~{ ~a~}~%") (location->string (error-location c)) (gettext (condition-message c) %gettext-domain)) (exit 1)) + ((and (message-condition? c) (fix-hint? c)) + (format (current-error-port) "~a: error: ~a~%" + (program-name) + (gettext (condition-message c) %gettext-domain)) + (display-hint (condition-fix-hint c)) + (exit 1)) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. (leave (G_ "~a~%") |