summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLeo Famulari <leo@famulari.name>2016-11-25 11:20:21 -0500
committerLeo Famulari <leo@famulari.name>2016-11-25 11:20:21 -0500
commitde32aa74b4f7762e887e80047804c42d495ab841 (patch)
treebc37856ba9036563aa9ca7809ea3e8cefcb670e9 /guix
parentd46491779e18cf614caeeb1b4becbd9171c64416 (diff)
parentd66cbd1adc799b08e66cd912822c6220499b4876 (diff)
Merge branch 'master' into python-build-system
Diffstat (limited to 'guix')
-rw-r--r--guix/build/syscalls.scm220
-rw-r--r--guix/derivations.scm4
-rw-r--r--guix/download.scm159
-rw-r--r--guix/gexp.scm3
-rw-r--r--guix/profiles.scm4
-rw-r--r--guix/scripts/download.scm58
-rw-r--r--guix/scripts/lint.scm43
-rw-r--r--guix/scripts/perform-download.scm113
-rw-r--r--guix/scripts/system.scm3
-rw-r--r--guix/store.scm29
-rw-r--r--guix/tests/http.scm120
-rw-r--r--guix/ui.scm6
12 files changed, 669 insertions, 93 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 2cee6544c4..9386c0f5d0 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -87,12 +87,16 @@
all-network-interface-names
network-interface-names
network-interface-flags
+ network-interface-netmask
loopback-network-interface?
network-interface-address
set-network-interface-flags
set-network-interface-address
+ set-network-interface-netmask
set-network-interface-up
configure-network-interface
+ add-network-route/gateway
+ delete-network-route
interface?
interface-name
@@ -202,7 +206,7 @@ result is the alignment of the \"most strictly aligned component\"."
types ...))))
(define-syntax write-type
- (syntax-rules (~ array)
+ (syntax-rules (~ array *)
((_ bv offset (type ~ order) value)
(bytevector-uint-set! bv offset value
(endianness order) (sizeof* type)))
@@ -215,6 +219,9 @@ result is the alignment of the \"most strictly aligned component\"."
((head . tail)
(write-type bv o type head)
(loop (+ 1 i) tail (+ o (sizeof* type))))))))
+ ((_ bv offset '* value)
+ (bytevector-uint-set! bv offset (pointer-address value)
+ (native-endianness) (sizeof* '*)))
((_ bv offset type value)
(bytevector-uint-set! bv offset value
(native-endianness) (sizeof* type)))))
@@ -262,6 +269,29 @@ result is the alignment of the \"most strictly aligned component\"."
(align offset type0)
type0))))))
+(define-syntax define-c-struct-macro
+ (syntax-rules ()
+ "Define NAME as a macro that can be queried to get information about the C
+struct it represents. In particular:
+
+ (NAME field-offset FIELD)
+
+returns the offset in bytes of FIELD within the C struct represented by NAME."
+ ((_ name ((fields types) ...))
+ (define-c-struct-macro name
+ (fields ...) 0 ()
+ ((fields types) ...)))
+ ((_ name (fields ...) offset (clauses ...) ((field type) rest ...))
+ (define-c-struct-macro name
+ (fields ...)
+ (+ (align offset type) (type-size type))
+ (clauses ... ((_ field-offset field) (align offset type)))
+ (rest ...)))
+ ((_ name (fields ...) offset (clauses ...) ())
+ (define-syntax name
+ (syntax-rules (field-offset fields ...)
+ clauses ...)))))
+
(define-syntax define-c-struct
(syntax-rules ()
"Define SIZE as the size in bytes of the C structure made of FIELDS. READ
@@ -269,6 +299,8 @@ as a deserializer and WRITE! as a serializer for the C structure with the
given TYPES. READ uses WRAP-FIELDS to return its value."
((_ name size wrap-fields read write! (fields types) ...)
(begin
+ (define-c-struct-macro name
+ ((fields types) ...))
(define size
(struct-size 0 () types ...))
(define (write! bv offset fields ...)
@@ -276,6 +308,12 @@ given TYPES. READ uses WRAP-FIELDS to return its value."
(define* (read bv #:optional (offset 0))
(read-types wrap-fields bv offset (types ...) ()))))))
+(define-syntax-rule (c-struct-field-offset type field)
+ "Return the offset in BYTES of FIELD within TYPE, where TYPE is a C struct
+defined with 'define-c-struct' and FIELD is a field identifier. An
+expansion-time error is raised if FIELD does not exist in TYPE."
+ (type field-offset field))
+
;;;
;;; FFI.
@@ -761,6 +799,22 @@ exception if it's already taken."
(if (string-contains %host-type "linux")
#x8916 ;GNU/Linux
-1)) ;FIXME: GNU/Hurd?
+(define SIOCGIFNETMASK
+ (if (string-contains %host-type "linux")
+ #x891b ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
+(define SIOCSIFNETMASK
+ (if (string-contains %host-type "linux")
+ #x891c ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
+(define SIOCADDRT
+ (if (string-contains %host-type "linux")
+ #x890B ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
+(define SIOCDELRT
+ (if (string-contains %host-type "linux")
+ #x890C ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
;; Flags and constants from <net/if.h>.
@@ -770,10 +824,13 @@ exception if it's already taken."
(define IF_NAMESIZE 16) ;maximum interface name size
-(define ifconf-struct
- ;; 'struct ifconf', from <net/if.h>.
- (list int ;int ifc_len
- '*)) ;struct ifreq *ifc_ifcu
+(define-c-struct %ifconf-struct
+ sizeof-ifconf
+ list
+ read-ifconf
+ write-ifconf!
+ (length int) ;int ifc_len
+ (request '*)) ;struct ifreq *ifc_ifcu
(define ifreq-struct-size
;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the
@@ -865,15 +922,18 @@ to interfaces that are currently up."
(sock (or sock (socket SOCK_STREAM AF_INET 0)))
(len (* ifreq-struct-size 10))
(reqs (make-bytevector len))
- (conf (make-c-struct ifconf-struct
- (list len (bytevector->pointer reqs)))))
+ (conf (make-bytevector sizeof-ifconf)))
+ (write-ifconf! conf 0
+ len (bytevector->pointer reqs))
+
(let-values (((ret err)
- (%ioctl (fileno sock) SIOCGIFCONF conf)))
+ (%ioctl (fileno sock) SIOCGIFCONF
+ (bytevector->pointer conf))))
(when close?
(close-port sock))
(if (zero? ret)
(bytevector->string-list reqs ifreq-struct-size
- (match (parse-c-struct conf ifconf-struct)
+ (match (read-ifconf conf)
((len . _) len)))
(throw 'system-error "network-interface-list"
"network-interface-list: ~A"
@@ -961,6 +1021,22 @@ interface NAME."
(list name (strerror err))
(list err))))))
+(define (set-network-interface-netmask socket name sockaddr)
+ "Set the network mask of interface NAME to SOCKADDR."
+ (let ((req (make-bytevector ifreq-struct-size)))
+ (bytevector-copy! (string->utf8 name) 0 req 0
+ (min (string-length name) (- IF_NAMESIZE 1)))
+ ;; Set the 'ifr_addr' field.
+ (write-socket-address! sockaddr req IF_NAMESIZE)
+ (let-values (((ret err)
+ (%ioctl (fileno socket) SIOCSIFNETMASK
+ (bytevector->pointer req))))
+ (unless (zero? ret)
+ (throw 'system-error "set-network-interface-netmask"
+ "set-network-interface-netmask on ~A: ~A"
+ (list name (strerror err))
+ (list err))))))
+
(define (network-interface-address socket name)
"Return the address of network interface NAME. The result is an object of
the same type as that returned by 'make-socket-address'."
@@ -977,15 +1053,35 @@ the same type as that returned by 'make-socket-address'."
(list name (strerror err))
(list err))))))
-(define (configure-network-interface name sockaddr flags)
+(define (network-interface-netmask socket name)
+ "Return the netmask of network interface NAME. The result is an object of
+the same type as that returned by 'make-socket-address'."
+ (let ((req (make-bytevector ifreq-struct-size)))
+ (bytevector-copy! (string->utf8 name) 0 req 0
+ (min (string-length name) (- IF_NAMESIZE 1)))
+ (let-values (((ret err)
+ (%ioctl (fileno socket) SIOCGIFNETMASK
+ (bytevector->pointer req))))
+ (if (zero? ret)
+ (read-socket-address req IF_NAMESIZE)
+ (throw 'system-error "network-interface-netmask"
+ "network-interface-netmask on ~A: ~A"
+ (list name (strerror err))
+ (list err))))))
+
+(define* (configure-network-interface name sockaddr flags
+ #:key netmask)
"Configure network interface NAME to use SOCKADDR, an address as returned by
-'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants."
+'make-socket-address', and FLAGS, a bitwise-or of IFF_* constants. If NETMASK
+is true, it must be a socket address to use as the network mask."
(let ((sock (socket (sockaddr:fam sockaddr) SOCK_STREAM 0)))
(dynamic-wind
(const #t)
(lambda ()
(set-network-interface-address sock name sockaddr)
- (set-network-interface-flags sock name flags))
+ (set-network-interface-flags sock name flags)
+ (when netmask
+ (set-network-interface-netmask sock name netmask)))
(lambda ()
(close-port sock)))))
@@ -1004,6 +1100,106 @@ the same type as that returned by 'make-socket-address'."
;;;
+;;; Network routes.
+;;;
+
+(define-c-struct %rtentry ;'struct rtentry' from <net/route.h>
+ sizeof-rtentry
+ list
+ read-rtentry
+ write-rtentry!
+ (pad1 unsigned-long)
+ (destination (array uint8 16)) ;struct sockaddr
+ (gateway (array uint8 16)) ;struct sockaddr
+ (genmask (array uint8 16)) ;struct sockaddr
+ (flags unsigned-short)
+ (pad2 short)
+ (pad3 long)
+ (tos uint8)
+ (class uint8)
+ (pad4 (array uint8 (if (= 8 (sizeof* '*)) 3 1)))
+ (metric short)
+ (device '*)
+ (mtu unsigned-long)
+ (window unsigned-long)
+ (initial-rtt unsigned-short))
+
+(define RTF_UP #x0001) ;'rtentry' flags from <net/route.h>
+(define RTF_GATEWAY #x0002)
+
+(define %sockaddr-any
+ (make-socket-address AF_INET INADDR_ANY 0))
+
+(define add-network-route/gateway
+ ;; To allow field names to be matched as literals, we need to move them out
+ ;; of the lambda's body since the parameters have the same name. A lot of
+ ;; fuss for very little.
+ (let-syntax ((gateway-offset (identifier-syntax
+ (c-struct-field-offset %rtentry gateway)))
+ (destination-offset (identifier-syntax
+ (c-struct-field-offset %rtentry destination)))
+ (genmask-offset (identifier-syntax
+ (c-struct-field-offset %rtentry genmask))))
+ (lambda* (socket gateway
+ #:key (destination %sockaddr-any) (genmask %sockaddr-any))
+ "Add a network route for DESTINATION (a socket address as returned by
+'make-socket-address') that goes through GATEWAY (a socket address). For
+instance, the call:
+
+ (add-network-route/gateway sock
+ (make-socket-address
+ AF_INET
+ (inet-pton AF_INET \"192.168.0.1\")
+ 0))
+
+is equivalent to this 'net-tools' command:
+
+ route add -net default gw 192.168.0.1
+
+because the default value of DESTINATION is \"0.0.0.0\"."
+ (let ((route (make-bytevector sizeof-rtentry 0)))
+ (write-socket-address! gateway route gateway-offset)
+ (write-socket-address! destination route destination-offset)
+ (write-socket-address! genmask route genmask-offset)
+ (bytevector-u16-native-set! route
+ (c-struct-field-offset %rtentry flags)
+ (logior RTF_UP RTF_GATEWAY))
+ (let-values (((ret err)
+ (%ioctl (fileno socket) SIOCADDRT
+ (bytevector->pointer route))))
+ (unless (zero? ret)
+ (throw 'system-error "add-network-route/gateway"
+ "add-network-route/gateway: ~A"
+ (list (strerror err))
+ (list err))))))))
+
+(define delete-network-route
+ (let-syntax ((destination-offset (identifier-syntax
+ (c-struct-field-offset %rtentry destination))))
+ (lambda* (socket destination)
+ "Delete the network route for DESTINATION. For instance, the call:
+
+ (delete-network-route sock
+ (make-socket-address AF_INET INADDR_ANY 0))
+
+is equivalent to the 'net-tools' command:
+
+ route del -net default
+"
+
+ (let ((route (make-bytevector sizeof-rtentry 0)))
+ (write-socket-address! destination route destination-offset)
+ (let-values (((ret err)
+ (%ioctl (fileno socket) SIOCDELRT
+ (bytevector->pointer route))))
+ (unless (zero? ret)
+ (throw 'system-error "delete-network-route"
+ "delete-network-route: ~A"
+ (list (strerror err))
+ (list err))))))))
+
+
+;;;
;;; Details about network interfaces---aka. 'getifaddrs'.
;;;
diff --git a/guix/derivations.scm b/guix/derivations.scm
index e378a7cb03..7ed9bd61d3 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -86,6 +86,7 @@
derivation-path->output-path
derivation-path->output-paths
derivation
+ raw-derivation
map-derivation
@@ -1306,3 +1307,6 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?."
(define built-derivations
(store-lift build-derivations))
+
+(define raw-derivation
+ (store-lift derivation))
diff --git a/guix/download.scm b/guix/download.scm
index 0c275053c5..e2e5cee777 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -309,27 +309,64 @@
(let ((module (resolve-interface '(gnu packages tls))))
(module-ref module 'gnutls)))
-(define* (url-fetch url hash-algo hash
- #:optional name
- #:key (system (%current-system))
- (guile (default-guile)))
- "Return a fixed-output derivation that fetches URL (a string, or a list of
-strings denoting alternate URLs), which is expected to have hash HASH of type
-HASH-ALGO (a symbol). By default, the file name is the base name of URL;
-optionally, NAME can specify a different file name.
+(define built-in-builders*
+ (let ((cache (make-weak-key-hash-table)))
+ (lambda ()
+ "Return, as a monadic value, the list of built-in builders supported by
+the daemon."
+ (lambda (store)
+ ;; Memoize the result to avoid repeated RPCs.
+ (values (or (hashq-ref cache store)
+ (let ((result (built-in-builders store)))
+ (hashq-set! cache store result)
+ result))
+ store)))))
-When one of the URL starts with mirror://, then its host part is
-interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
+(define* (built-in-download file-name url
+ #:key system hash-algo hash
+ mirrors content-addressed-mirrors
+ (guile 'unused))
+ "Download FILE-NAME from URL using the built-in 'download' builder.
-Alternately, when URL starts with file://, return the corresponding file name
-in the store."
- (define file-name
- (match url
- ((head _ ...)
- (basename head))
- (_
- (basename url))))
+This is an \"out-of-band\" download in that the returned derivation does not
+explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the
+download by itself using its own dependencies."
+ (mlet %store-monad ((mirrors (lower-object mirrors))
+ (content-addressed-mirrors
+ (lower-object content-addressed-mirrors)))
+ (raw-derivation file-name "builtin:download" '()
+ #:system system
+ #:hash-algo hash-algo
+ #:hash hash
+ #:inputs `((,mirrors)
+ (,content-addressed-mirrors))
+ ;; Honor the user's proxy and locale settings.
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
+
+ #:env-vars `(("url" . ,(object->string url))
+ ("mirrors" . ,mirrors)
+ ("content-addressed-mirrors"
+ . ,content-addressed-mirrors))
+
+ ;; Do not offload this derivation because we cannot be
+ ;; sure that the remote daemon supports the 'download'
+ ;; built-in. We may remove this limitation when support
+ ;; for that built-in is widespread.
+ #:local-build? #t)))
+
+(define* (in-band-download file-name url
+ #:key system hash-algo hash
+ mirrors content-addressed-mirrors
+ guile)
+ "Download FILE-NAME from URL using a normal, \"in-band\" fixed-output
+derivation.
+
+This is now deprecated since it has the drawback of causing bootstrapping
+issues: we may need to build GnuTLS just to be able to download the source of
+GnuTLS itself and its dependencies. See <http://bugs.gnu.org/22774>."
(define need-gnutls?
;; True if any of the URLs need TLS support.
(let ((https? (cut string-prefix? "https://" <>)))
@@ -366,47 +403,81 @@ in the store."
read))))
(url-fetch (value-from-environment "guix download url")
#$output
- #:mirrors (call-with-input-file #$%mirror-file read)
+ #:mirrors (call-with-input-file #$mirrors read)
;; Content-addressed mirrors.
#:hashes
(value-from-environment "guix download hashes")
#:content-addressed-mirrors
- (primitive-load #$%content-addressed-mirror-file)
+ (primitive-load #$content-addressed-mirrors)
;; No need to validate certificates since we know the
;; hash of the expected result.
#:verify-certificate? #f)))))
+ (mlet %store-monad ((guile (package->derivation guile system)))
+ (gexp->derivation file-name builder
+ #:guile-for-build guile
+ #:system system
+ #:hash-algo hash-algo
+ #:hash hash
+
+ ;; Use environment variables and a fixed script
+ ;; name so there's only one script in store for
+ ;; all the downloads.
+ #:script-name "download"
+ #:env-vars
+ `(("guix download url" . ,(object->string url))
+ ("guix download hashes"
+ . ,(object->string `((,hash-algo . ,hash)))))
+
+ ;; Honor the user's proxy settings.
+ #:leaked-env-vars '("http_proxy" "https_proxy")
+
+ ;; In general, offloading downloads is not a good
+ ;; idea. Daemons before 0.8.3 would also
+ ;; interpret this as "do not substitute" (see
+ ;; <https://bugs.gnu.org/18747>.)
+ #:local-build? #t)))
+
+(define* (url-fetch url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile)))
+ "Return a fixed-output derivation that fetches URL (a string, or a list of
+strings denoting alternate URLs), which is expected to have hash HASH of type
+HASH-ALGO (a symbol). By default, the file name is the base name of URL;
+optionally, NAME can specify a different file name.
+
+When one of the URL starts with mirror://, then its host part is
+interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
+
+Alternately, when URL starts with file://, return the corresponding file name
+in the store."
+ (define file-name
+ (match url
+ ((head _ ...)
+ (basename head))
+ (_
+ (basename url))))
+
(let ((uri (and (string? url) (string->uri url))))
(if (or (and (string? url) (not uri))
(and uri (memq (uri-scheme uri) '(#f file))))
(interned-file (if uri (uri-path uri) url)
(or name file-name))
- (mlet %store-monad ((guile (package->derivation guile system)))
- (gexp->derivation (or name file-name) builder
- #:guile-for-build guile
- #:system system
- #:hash-algo hash-algo
- #:hash hash
-
- ;; Use environment variables and a fixed script
- ;; name so there's only one script in store for
- ;; all the downloads.
- #:script-name "download"
- #:env-vars
- `(("guix download url" . ,(object->string url))
- ("guix download hashes"
- . ,(object->string `((,hash-algo . ,hash)))))
-
- ;; Honor the user's proxy settings.
- #:leaked-env-vars '("http_proxy" "https_proxy")
-
- ;; In general, offloading downloads is not a good
- ;; idea. Daemons before 0.8.3 would also
- ;; interpret this as "do not substitute" (see
- ;; <https://bugs.gnu.org/18747>.)
- #:local-build? #t)))))
+ (mlet* %store-monad ((builtins (built-in-builders*))
+ (download -> (if (member "download" builtins)
+ built-in-download
+ in-band-download)))
+ (download (or name file-name) url
+ #:guile guile
+ #:system system
+ #:hash-algo hash-algo
+ #:hash hash
+ #:mirrors %mirror-file
+ #:content-addressed-mirrors
+ %content-addressed-mirror-file)))))
(define* (url-fetch/tarbomb url hash-algo hash
#:optional name
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 05178a5ecc..fd5dc49233 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -453,9 +453,6 @@ whether this should be considered a \"native\" input or not."
'()))
(gexp-references gexp)))))
-(define raw-derivation
- (store-lift derivation))
-
(define* (lower-inputs inputs
#:key system target)
"Turn any package from INPUTS into a derivation for SYSTEM; return the
diff --git a/guix/profiles.scm b/guix/profiles.scm
index b56b8f4c79..0b317ef51e 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -501,10 +501,6 @@ if not found."
#t))))
items))
- ;; TODO: Factorize.
- (define references*
- (store-lift references))
-
(with-monad %store-monad
(match (manifest-entry-item entry)
((? package? package)
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index ec30b05ac0..dffff79729 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -23,12 +23,15 @@
#:use-module (guix hash)
#:use-module (guix utils)
#:use-module (guix base32)
- #:use-module (guix download)
- #:use-module ((guix build download) #:select (current-terminal-columns))
- #:use-module ((guix build syscalls) #:select (terminal-columns))
+ #:use-module ((guix download) #:hide (url-fetch))
+ #:use-module ((guix build download)
+ #:select (url-fetch current-terminal-columns))
+ #:use-module ((guix build syscalls)
+ #:select (terminal-columns))
#:use-module (web uri)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
@@ -39,15 +42,31 @@
;;; Command-line options.
;;;
+(define (download-to-file url file)
+ "Download the file at URI to FILE. Return FILE."
+ (let ((uri (string->uri url)))
+ (match (uri-scheme uri)
+ ((or 'file #f)
+ (copy-file (uri-path uri) file))
+ (_
+ (url-fetch url file)))
+ file))
+
+(define* (download-to-store* url #:key (verify-certificate? #t))
+ (with-store store
+ (download-to-store store url
+ #:verify-certificate? verify-certificate?)))
+
(define %default-options
;; Alist of default option values.
`((format . ,bytevector->nix-base32-string)
- (verify-certificate? . #t)))
+ (verify-certificate? . #t)
+ (download-proc . ,download-to-store*)))
(define (show-help)
(display (_ "Usage: guix download [OPTION] URL
-Download the file at URL, add it to the store, and print its store path
-and the hash of its contents.
+Download the file at URL to the store or to the given file, and print its
+file name and the hash of its contents.
Supported formats: 'nix-base32' (default), 'base32', and 'base16'
('hex' and 'hexadecimal' can be used as well).\n"))
@@ -56,6 +75,8 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
(format #t (_ "
--no-check-certificate
do not validate the certificate of HTTPS servers "))
+ (format #f (_ "
+ -o, --output=FILE download to FILE"))
(newline)
(display (_ "
-h, --help display this help and exit"))
@@ -84,6 +105,12 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
(option '("no-check-certificate") #f #f
(lambda (opt name arg result)
(alist-cons 'verify-certificate? #f result)))
+ (option '(#\o "output") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'download-proc
+ (lambda* (url #:key verify-certificate?)
+ (download-to-file url arg))
+ (alist-delete 'download result))))
(option '(#\h "help") #f #f
(lambda args
@@ -113,24 +140,17 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
(with-error-handling
(let* ((opts (parse-options))
- (store (open-connection))
(arg (or (assq-ref opts 'argument)
(leave (_ "no download URI was specified~%"))))
(uri (or (string->uri arg)
(leave (_ "~a: failed to parse URI~%")
arg)))
- (path (case (uri-scheme uri)
- ((file)
- (add-to-store store (basename (uri-path uri))
- #f "sha256" (uri-path uri)))
- (else
- (parameterize ((current-terminal-columns
- (terminal-columns)))
- (download-to-store store (uri->string uri)
- (basename (uri-path uri))
- #:verify-certificate?
- (assoc-ref opts
- 'verify-certificate?))))))
+ (fetch (assq-ref opts 'download-proc))
+ (path (parameterize ((current-terminal-columns
+ (terminal-columns)))
+ (fetch arg
+ #:verify-certificate?
+ (assq-ref opts 'verify-certificate?))))
(hash (call-with-input-file
(or path
(leave (_ "~a: download failed~%")
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index be29e36ce1..9b991786c3 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -67,6 +67,7 @@
check-home-page
check-source
check-source-file-name
+ check-mirror-url
check-license
check-vulnerabilities
check-formatting
@@ -600,6 +601,14 @@ descriptions maintained upstream."
(location->string loc) (package-full-name package)
(fill-paragraph (escape-quotes upstream) 77 7)))))))
+(define (origin-uris origin)
+ "Return the list of URIs (strings) for ORIGIN."
+ (match (origin-uri origin)
+ ((? string? uri)
+ (list uri))
+ ((uris ...)
+ uris)))
+
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
@@ -616,10 +625,7 @@ descriptions maintained upstream."
(let ((origin (package-source package)))
(when (and origin
(eqv? (origin-method origin) url-fetch))
- (let* ((strings (origin-uri origin))
- (uris (if (list? strings)
- (map string->uri strings)
- (list (string->uri strings)))))
+ (let ((uris (map string->uri (origin-uris origin))))
;; Just make sure that at least one of the URIs is valid.
(call-with-values
@@ -659,6 +665,31 @@ descriptions maintained upstream."
(_ "the source file name should contain the package name")
'source))))
+(define (check-mirror-url package)
+ "Check whether PACKAGE uses source URLs that should be 'mirror://'."
+ (define (check-mirror-uri uri) ;XXX: could be optimized
+ (let loop ((mirrors %mirrors))
+ (match mirrors
+ (()
+ #t)
+ (((mirror-id mirror-urls ...) rest ...)
+ (match (find (cut string-prefix? <> uri) mirror-urls)
+ (#f
+ (loop rest))
+ (prefix
+ (emit-warning package
+ (format #f (_ "URL should be \
+'mirror://~a/~a'")
+ mirror-id
+ (string-drop uri (string-length prefix)))
+ 'source)))))))
+
+ (let ((origin (package-source package)))
+ (when (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (let ((uris (origin-uris origin)))
+ (for-each check-mirror-uri uris)))))
+
(define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation."
(catch #t
@@ -901,6 +932,10 @@ or a list thereof")
(description "Validate source URLs")
(check check-source))
(lint-checker
+ (name 'mirror-url)
+ (description "Suggest 'mirror://' URLs")
+ (check check-mirror-url))
+ (lint-checker
(name 'source-file-name)
(description "Validate file names of sources")
(check check-source-file-name))
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
new file mode 100644
index 0000000000..0d2e7089aa
--- /dev/null
+++ b/guix/scripts/perform-download.scm
@@ -0,0 +1,113 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts perform-download)
+ #:use-module (guix ui)
+ #:use-module (guix derivations)
+ #:use-module ((guix store) #:select (derivation-path?))
+ #:use-module (guix build download)
+ #:use-module (ice-9 match)
+ #:export (guix-perform-download))
+
+;; This program is a helper for the daemon's 'download' built-in builder.
+
+(define-syntax derivation-let
+ (syntax-rules ()
+ ((_ drv ((id name) rest ...) body ...)
+ (let ((id (assoc-ref (derivation-builder-environment-vars drv)
+ name)))
+ (derivation-let drv (rest ...) body ...)))
+ ((_ drv () body ...)
+ (begin body ...))))
+
+(define %user-module
+ ;; Module in which content-address mirror procedures are evaluated.
+ (let ((module (make-fresh-user-module)))
+ (module-use! module (resolve-interface '(guix base32)))
+ module))
+
+(define (perform-download drv)
+ "Perform the download described by DRV, a fixed-output derivation."
+ (derivation-let drv ((url "url")
+ (output "out")
+ (executable "executable")
+ (mirrors "mirrors")
+ (content-addressed-mirrors "content-addressed-mirrors"))
+ (unless url
+ (leave (_ "~a: missing URL~%") (derivation-file-name drv)))
+
+ (let* ((url (call-with-input-string url read))
+ (drv-output (assoc-ref (derivation-outputs drv) "out"))
+ (algo (derivation-output-hash-algo drv-output))
+ (hash (derivation-output-hash drv-output)))
+ (unless (and algo hash)
+ (leave (_ "~a is not a fixed-output derivation~%")
+ (derivation-file-name drv)))
+
+ ;; We're invoked by the daemon, which gives us write access to OUTPUT.
+ (when (url-fetch url output
+ #:mirrors (if mirrors
+ (call-with-input-file mirrors read)
+ '())
+ #:content-addressed-mirrors
+ (if content-addressed-mirrors
+ (call-with-input-file content-addressed-mirrors
+ (lambda (port)
+ (eval (read port) %user-module)))
+ '())
+ #:hashes `((,algo . ,hash))
+
+ ;; Since DRV's output hash is known, X.509 certificate
+ ;; validation is pointless.
+ #:verify-certificate? #f)
+ (when (and executable (string=? executable "1"))
+ (chmod output #o755))))))
+
+(define (assert-low-privileges)
+ (when (zero? (getuid))
+ (leave (_ "refusing to run with elevated privileges (UID ~a)~%")
+ (getuid))))
+
+(define (guix-perform-download . args)
+ "Perform the download described by the given fixed-output derivation.
+
+This is an \"out-of-band\" download in that this code is executed directly by
+the daemon and not explicitly described as an input of the derivation. This
+allows us to sidestep bootstrapping problems, such downloading the source code
+of GnuTLS over HTTPS, before we have built GnuTLS. See
+<http://bugs.gnu.org/22774>."
+ (with-error-handling
+ (match args
+ (((? derivation-path? drv))
+ ;; This program must be invoked by guix-daemon under an unprivileged
+ ;; UID to prevent things downloading from 'file:///etc/shadow' or
+ ;; arbitrary code execution via the content-addressed mirror
+ ;; procedures. (That means we exclude users who did not pass
+ ;; '--build-users-group'.)
+ (assert-low-privileges)
+ (perform-download (call-with-input-file drv read-derivation)))
+ (("--version")
+ (show-version-and-exit))
+ (x
+ (leave (_ "fixed-output derivation name expected~%"))))))
+
+;; Local Variables:
+;; eval: (put 'derivation-let 'scheme-indent-function 2)
+;; End:
+
+;; perform-download.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 71ddccfa61..bb373a6726 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -77,9 +77,6 @@
;;; Installation.
;;;
-;; TODO: Factorize.
-(define references*
- (store-lift references))
(define topologically-sorted*
(store-lift topologically-sorted))
diff --git a/guix/store.scm b/guix/store.scm
index 43cfda9214..7f54b87db1 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -95,8 +95,10 @@
path-info-registration-time
path-info-nar-size
+ built-in-builders
references
references/substitutes
+ references*
requisites
referrers
optimize-store
@@ -187,7 +189,8 @@
(query-substitutable-paths 32)
(query-valid-derivers 33)
(optimize-store 34)
- (verify-store 35))
+ (verify-store 35)
+ (built-in-builders 80))
(define-enumerate-type hash-algo
;; hash.hh
@@ -283,7 +286,7 @@
(write-string (bytevector->base16-string arg) p))))
(define-syntax read-arg
- (syntax-rules (integer boolean string store-path store-path-list
+ (syntax-rules (integer boolean string store-path store-path-list string-list
substitutable-path-list path-info base16)
((_ integer p)
(read-int p))
@@ -295,6 +298,8 @@
(read-store-path p))
((_ store-path-list p)
(read-store-path-list p))
+ ((_ string-list p)
+ (read-string-list p))
((_ substitutable-path-list p)
(read-substitutable-path-list p))
((_ path-info p)
@@ -914,6 +919,23 @@ that there is no guarantee that the order of the resulting list matches the
order of PATHS."
substitutable-path-list))
+(define built-in-builders
+ (let ((builders (operation (built-in-builders)
+ "Return the built-in builders."
+ string-list)))
+ (lambda (store)
+ "Return the names of the supported built-in derivation builders
+supported by STORE."
+ ;; Check whether STORE's version supports this RPC and built-in
+ ;; derivation builders in general, which appeared in Guix > 0.11.0.
+ ;; Return the empty list if it doesn't. Note that this RPC does not
+ ;; exist in 'nix-daemon'.
+ (if (or (> (nix-server-major-version store) #x100)
+ (and (= (nix-server-major-version store) #x100)
+ (>= (nix-server-minor-version store) #x60)))
+ (builders store)
+ '()))))
+
(define-operation (optimize-store)
"Optimize the store by hard-linking identical files (\"deduplication\".)
Return #t on success."
@@ -1149,6 +1171,9 @@ where FILE is the entry's absolute file name and STAT is the result of
(define set-build-options*
(store-lift set-build-options))
+(define references*
+ (store-lift references))
+
(define-inlinable (current-system)
;; Consult the %CURRENT-SYSTEM fluid at bind time. This is equivalent to
;; (lift0 %current-system %store-monad), but inlinable, thus avoiding
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
new file mode 100644
index 0000000000..fe1e120c5d
--- /dev/null
+++ b/guix/tests/http.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix tests http)
+ #:use-module (ice-9 threads)
+ #:use-module (web server)
+ #:use-module (web server http)
+ #:use-module (web response)
+ #:use-module (srfi srfi-39)
+ #:export (with-http-server
+ call-with-http-server
+ %http-server-port
+ %http-server-socket
+ %local-url))
+
+;;; Commentary:
+;;;
+;;; Code to spawn a Web server for testing purposes.
+;;;
+;;; Code:
+
+(define %http-server-port
+ ;; TCP port to use for the stub HTTP server.
+ (make-parameter 9999))
+
+(define (%local-url)
+ ;; URL to use for 'home-page' tests.
+ (string-append "http://localhost:" (number->string (%http-server-port))
+ "/foo/bar"))
+
+(define %http-server-socket
+ ;; Listening socket for the web server. It is useful to export it so that
+ ;; tests can check whether we succeeded opening the socket and tests skip if
+ ;; needed.
+ (delay
+ (catch 'system-error
+ (lambda ()
+ (let ((sock (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (bind sock
+ (make-socket-address AF_INET INADDR_LOOPBACK
+ (%http-server-port)))
+ sock))
+ (lambda args
+ (let ((err (system-error-errno args)))
+ (format (current-error-port)
+ "warning: cannot run Web server for tests: ~a~%"
+ (strerror err))
+ #f)))))
+
+(define (http-write server client response body)
+ "Write RESPONSE."
+ (let* ((response (write-response response client))
+ (port (response-port response)))
+ (cond
+ ((not body)) ;pass
+ (else
+ (write-response-body response body)))
+ (close-port port)
+ (quit #t) ;exit the server thread
+ (values)))
+
+;; Mutex and condition variable to synchronize with the HTTP server.
+(define %http-server-lock (make-mutex))
+(define %http-server-ready (make-condition-variable))
+
+(define (http-open . args)
+ "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+ (with-mutex %http-server-lock
+ (let ((result (apply (@@ (web server http) http-open) args)))
+ (signal-condition-variable %http-server-ready)
+ result)))
+
+(define-server-impl stub-http-server
+ ;; Stripped-down version of Guile's built-in HTTP server.
+ http-open
+ (@@ (web server http) http-read)
+ http-write
+ (@@ (web server http) http-close))
+
+(define (call-with-http-server code data thunk)
+ "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
+ (define (server-body)
+ (define (handle request body)
+ (values (build-response #:code code
+ #:reason-phrase "Such is life")
+ data))
+
+ (catch 'quit
+ (lambda ()
+ (run-server handle stub-http-server
+ `(#:socket ,(force %http-server-socket))))
+ (const #t)))
+
+ (with-mutex %http-server-lock
+ (let ((server (make-thread server-body)))
+ (wait-condition-variable %http-server-ready %http-server-lock)
+ ;; Normally SERVER exits automatically once it has received a request.
+ (thunk))))
+
+(define-syntax-rule (with-http-server code data body ...)
+ (call-with-http-server code data (lambda () body ...)))
+
+;;; http.scm ends here
diff --git a/guix/ui.scm b/guix/ui.scm
index 9af8648211..cafb3c6705 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1094,7 +1094,8 @@ DURATION-RELATION with the current time."
(removed (lset-difference
equal-entry? (list-entries old) (list-entries new))))
(for-each (cut display-entry <> "+") added)
- (for-each (cut display-entry <> "-") removed)))
+ (for-each (cut display-entry <> "-") removed)
+ (newline)))
(display-diff profile gen1 gen2))
@@ -1184,7 +1185,8 @@ optionally contain a version number and an output name, as in these examples:
(define (show-guix-help)
(define (internal? command)
- (member command '("substitute" "authenticate" "offload")))
+ (member command '("substitute" "authenticate" "offload"
+ "perform-download")))
(format #t (_ "Usage: guix COMMAND ARGS...
Run COMMAND with ARGS.\n"))