summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLeo Famulari <leo@famulari.name>2018-01-11 14:22:50 -0800
committerLeo Famulari <leo@famulari.name>2018-01-11 14:22:50 -0800
commit4adb40bffc0dda8871878283887a0e0cd88d9578 (patch)
tree74d5fb686116002da72de4a1075d0ed8f307cec1 /guix
parent4610ab7c9a5327df0d475262817bc081a5891aa8 (diff)
parent138c08899ba73049de8afd2b74a8cf6845a1d9e1 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/derivations.scm4
-rw-r--r--guix/import/crate.scm4
-rw-r--r--guix/import/gem.scm2
-rw-r--r--guix/import/hackage.scm2
-rw-r--r--guix/scripts/publish.scm137
-rw-r--r--guix/serialization.scm8
-rw-r--r--guix/ssh.scm146
-rw-r--r--guix/store.scm8
-rw-r--r--guix/ui.scm6
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~%")