summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-11-14 21:20:46 +0100
committerMarius Bakke <mbakke@fastmail.com>2018-11-14 21:20:46 +0100
commit79ee97a144aaaa890be0724aaf796e2a771179d7 (patch)
treefddd2f20003d60e42eed7a614acea91a13d854d7 /guix
parent7d9d521fbcf1423f66d6f33208c03d5dacb7ba50 (diff)
parente921993c25626541385f191f0463cad8e5e5c5c7 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build/go-build-system.scm3
-rw-r--r--guix/ci.scm74
-rw-r--r--guix/gexp.scm7
-rw-r--r--guix/gnu-maintenance.scm115
-rw-r--r--guix/grafts.scm8
-rw-r--r--guix/nar.scm13
-rw-r--r--guix/scripts/package.scm10
-rw-r--r--guix/scripts/system.scm7
-rw-r--r--guix/store.scm68
-rw-r--r--guix/store/database.scm6
-rw-r--r--guix/store/deduplication.scm12
-rw-r--r--guix/tests.scm34
12 files changed, 318 insertions, 39 deletions
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 6be0167063..022d4fe16b 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -204,6 +204,9 @@ respectively."
$GOPATH/pkg, so we have to copy them into the output directory manually.
Compiled executable files should have already been installed to the store based
on $GOBIN in the build phase."
+ ;; TODO: From go-1.10 onward, the pkg folder should not be needed (see
+ ;; https://lists.gnu.org/archive/html/guix-devel/2018-11/msg00208.html).
+ ;; Remove it?
(when (file-exists? "pkg")
(copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg")))
#t)
diff --git a/guix/ci.scm b/guix/ci.scm
index 881f3d3927..1727297dd7 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -19,6 +19,7 @@
(define-module (guix ci)
#:use-module (guix http-client)
#:autoload (json parser) (json->scm)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (build?
build-id
@@ -27,9 +28,21 @@
build-status
build-timestamp
+ checkout?
+ checkout-commit
+ checkout-input
+
+ evaluation?
+ evaluation-id
+ evaluation-spec
+ evaluation-complete?
+ evaluation-checkouts
+
%query-limit
queued-builds
- latest-builds))
+ latest-builds
+ latest-evaluations
+ evaluation-for-commit))
;;; Commentary:
;;;
@@ -47,6 +60,20 @@
(status build-status) ;integer
(timestamp build-timestamp)) ;integer
+(define-record-type <checkout>
+ (make-checkout commit input)
+ checkout?
+ (commit checkout-commit) ;string (SHA1)
+ (input checkout-input)) ;string (name)
+
+(define-record-type <evaluation>
+ (make-evaluation id spec complete? checkouts)
+ evaluation?
+ (id evaluation-id) ;integer
+ (spec evaluation-spec) ;string
+ (complete? evaluation-complete?) ;Boolean
+ (checkouts evaluation-checkouts)) ;<checkout>*
+
(define %query-limit
;; Max number of builds requested in queries.
1000)
@@ -70,9 +97,50 @@
(number->string limit)))))
(map json->build queue)))
-(define* (latest-builds url #:optional (limit %query-limit))
+(define* (latest-builds url #:optional (limit %query-limit)
+ #:key evaluation system)
+ "Return the latest builds performed by the CI server at URL. If EVALUATION
+is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system
+string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
+ (define* (option name value #:optional (->string identity))
+ (if value
+ (string-append "&" name "=" (->string value))
+ ""))
+
(let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
- (number->string limit)))))
+ (number->string limit)
+ (option "evaluation" evaluation
+ number->string)
+ (option "system" system)))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
(map json->build latest)))
+
+(define (json->checkout json)
+ (make-checkout (hash-ref json "commit")
+ (hash-ref json "input")))
+
+(define (json->evaluation json)
+ (make-evaluation (hash-ref json "id")
+ (hash-ref json "specification")
+ (case (hash-ref json "in-progress")
+ ((0) #t)
+ (else #f))
+ (map json->checkout (hash-ref json "checkouts"))))
+
+(define* (latest-evaluations url #:optional (limit %query-limit))
+ "Return the latest evaluations performed by the CI server at URL."
+ (map json->evaluation
+ (json->scm
+ (http-fetch (string-append url "/api/evaluations?nr="
+ (number->string limit))))))
+
+
+(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
+ "Return the evaluations among the latest LIMIT evaluations that have COMMIT
+as one of their inputs."
+ (filter (lambda (evaluation)
+ (find (lambda (checkout)
+ (string=? (checkout-commit checkout) commit))
+ (evaluation-checkouts evaluation)))
+ (latest-evaluations url limit)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index f0963c6234..809c1188d4 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -211,7 +211,12 @@ OBJ must be an object that has an associated gexp compiler, such as a
(#f
(raise (condition (&gexp-input-error (input obj)))))
(lower
- (lower obj system target))))
+ ;; Cache in STORE the result of lowering OBJ.
+ (mlet %store-monad ((graft? (grafting?)))
+ (mcached (let ((lower (lookup-compiler obj)))
+ (lower obj system target))
+ obj
+ system target graft?)))))
(define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander)
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 3634f4bb27..bfd47a831d 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -21,6 +21,7 @@
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
+ #:use-module (sxml simple)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@@ -218,7 +219,7 @@ network to check in GNU's database."
;;;
-;;; Latest release.
+;;; Latest FTP release.
;;;
(define (ftp-server/directory package)
@@ -247,7 +248,7 @@ network to check in GNU's database."
(define (release-file? project file)
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
true."
- (and (not (string-suffix? ".sig" file))
+ (and (not (member (file-extension file) '("sig" "sign" "asc")))
(and=> (regexp-exec %tarball-rx file)
(lambda (match)
;; Filter out unrelated files, like `guile-www-1.1.1'.
@@ -440,6 +441,88 @@ hosted on ftp.gnu.org, or not under that name (this is the case for
#:server server
#:directory directory))))
+
+;;;
+;;; Latest HTTP release.
+;;;
+
+(define (html->sxml port)
+ "Read HTML from PORT and return the corresponding SXML tree."
+ (let ((str (get-string-all port)))
+ (catch #t
+ (lambda ()
+ ;; XXX: This is the poor developer's HTML-to-XML converter. It's good
+ ;; enough for directory listings at <https://kernel.org/pub> but if
+ ;; needed we could resort to (htmlprag) from Guile-Lib.
+ (call-with-input-string (string-replace-substring str "<hr>" "<hr />")
+ xml->sxml))
+ (const '(html))))) ;parse error
+
+(define (html-links sxml)
+ "Return the list of links found in SXML, the SXML tree of an HTML page."
+ (let loop ((sxml sxml)
+ (links '()))
+ (match sxml
+ (('a ('@ attributes ...) body ...)
+ (match (assq 'href attributes)
+ (#f (fold loop links body))
+ (('href url) (fold loop (cons url links) body))))
+ ((tag ('@ _ ...) body ...)
+ (fold loop links body))
+ ((tag body ...)
+ (fold loop links body))
+ (_
+ links))))
+
+(define* (latest-html-release package
+ #:key
+ (base-url "https://kernel.org/pub")
+ (directory (string-append "/" package))
+ (file->signature (cut string-append <> ".sig")))
+ "Return an <upstream-source> for the latest release of PACKAGE (a string) on
+SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page,
+typically a directory listing as found on 'https://kernel.org/pub'.
+
+FILE->SIGNATURE must be a procedure; it is passed a source file URL and must
+return the corresponding signature URL, or #f it signatures are unavailable."
+ (let* ((uri (string->uri (string-append base-url directory "/")))
+ (port (http-fetch/cached uri #:ttl 3600))
+ (sxml (html->sxml port)))
+ (define (url->release url)
+ (and (string=? url (basename url)) ;relative reference?
+ (release-file? package url)
+ (let-values (((name version)
+ (package-name->name+version (sans-extension url)
+ #\-)))
+ (upstream-source
+ (package name)
+ (version version)
+ (urls (list (string-append base-url directory "/" url)))
+ (signature-urls
+ (list (string-append base-url directory "/"
+ (file-sans-extension url)
+ ".sign")))))))
+
+ (define candidates
+ (filter-map url->release (html-links sxml)))
+
+ (close-port port)
+ (match candidates
+ (() #f)
+ ((first . _)
+ ;; Select the most recent release and return it.
+ (reduce (lambda (r1 r2)
+ (if (version>? (upstream-source-version r1)
+ (upstream-source-version r2))
+ r1 r2))
+ first
+ (coalesce-sources candidates))))))
+
+
+;;;
+;;; Updaters.
+;;;
+
(define %gnu-file-list-uri
;; URI of the file list for ftp.gnu.org.
(string->uri "https://ftp.gnu.org/find.txt.gz"))
@@ -555,19 +638,21 @@ releases are on gnu.org."
(define (latest-kernel.org-release package)
"Return the latest release of PACKAGE, the name of a kernel.org package."
- (let ((uri (string->uri (origin-uri (package-source package)))))
- (false-if-ftp-error
- (latest-ftp-release
- (package-name package)
- #:server "ftp.free.fr" ;a mirror reachable over FTP
- #:directory (string-append "/mirrors/ftp.kernel.org"
- (dirname (uri-path uri)))
-
- ;; kernel.org provides "foo-x.y.tar.sign" files, which are signatures of
- ;; the uncompressed tarball.
- #:file->signature (lambda (tarball)
- (string-append (file-sans-extension tarball)
- ".sign"))))))
+ (define %kernel.org-base
+ ;; This URL and sub-directories thereof are nginx-generated directory
+ ;; listings suitable for 'latest-html-release'.
+ "https://mirrors.edge.kernel.org/pub")
+
+ (define (file->signature file)
+ (string-append (file-sans-extension file) ".sign"))
+
+ (let* ((uri (string->uri (origin-uri (package-source package))))
+ (package (package-upstream-name package))
+ (directory (dirname (uri-path uri))))
+ (latest-html-release package
+ #:base-url %kernel.org-base
+ #:directory directory
+ #:file->signature file->signature)))
(define %gnu-updater
;; This is for everything at ftp.gnu.org.
diff --git a/guix/grafts.scm b/guix/grafts.scm
index f303e925f1..01e245d8eb 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -40,7 +40,8 @@
graft-derivation/shallow
%graft?
- set-grafting))
+ set-grafting
+ grafting?))
(define-record-type* <graft> graft make-graft
graft?
@@ -328,6 +329,11 @@ it otherwise. It returns the previous setting."
(lambda (store)
(values (%graft? enable?) store)))
+(define (grafting?)
+ "Return a Boolean indicating whether grafting is enabled."
+ (lambda (store)
+ (values (%graft?) store)))
+
;; Local Variables:
;; eval: (put 'with-cache 'scheme-indent-function 1)
;; End:
diff --git a/guix/nar.scm b/guix/nar.scm
index 0495b4a40c..8894f10d2b 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -22,8 +22,12 @@
#:use-module (guix build syscalls)
#:use-module ((guix build utils)
#:select (delete-file-recursively with-directory-excursion))
+
+ ;; XXX: Eventually we should use (guix store database) exclusively, and not
+ ;; (guix store) since this is "daemon-side" code.
#:use-module (guix store)
#:use-module (guix store database)
+
#:use-module (guix ui) ; for '_'
#:use-module (gcrypt hash)
#:use-module (guix pki)
@@ -88,15 +92,12 @@
REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET
before attempting to register it; otherwise, assume TARGET's locks are already
held."
-
- ;; XXX: Currently we have to call out to the daemon to check whether TARGET
- ;; is valid.
- (with-store store
- (unless (valid-path? store target)
+ (with-database %default-database-file db
+ (unless (path-id db target)
(when lock?
(lock-store-file target))
- (unless (valid-path? store target)
+ (unless (path-id db target)
;; If FILE already exists, delete it (it's invalid anyway.)
(when (file-exists? target)
(delete-file-recursively target))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 500fc9ac90..5743816324 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -771,9 +771,13 @@ processed, #f otherwise."
(('show requested-name)
(let-values (((name version)
(package-name->name+version requested-name)))
- (leave-on-EPIPE
- (for-each (cute package->recutils <> (current-output-port))
- (find-packages-by-name name version)))
+ (match (find-packages-by-name name version)
+ (()
+ (leave (G_ "~a~@[@~a~]: package not found~%") name version))
+ (packages
+ (leave-on-EPIPE
+ (for-each (cute package->recutils <> (current-output-port))
+ packages))))
#t))
(('search-paths kind)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index d2be0cf8fb..9ba9428a08 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -235,6 +235,13 @@ When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG."
the ownership of '~a' may be incorrect!~%")
target))
+ ;; If a previous installation was attempted, make sure we start anew; in
+ ;; particular, we don't want to keep a store database that might not
+ ;; correspond to what we're actually putting in the store.
+ (let ((state (string-append target "/var/guix")))
+ (when (file-exists? state)
+ (delete-file-recursively state)))
+
(chmod target #o755)
(let ((os-dir (derivation->output-path os-drv))
(format (lift format %store-monad))
diff --git a/guix/store.scm b/guix/store.scm
index b1bdbf3813..9dc651b26c 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -23,6 +23,7 @@
#:use-module (guix memoization)
#:use-module (guix serialization)
#:use-module (guix monads)
+ #:use-module (guix records)
#:use-module (guix base16)
#:use-module (guix base32)
#:use-module (gcrypt hash)
@@ -30,6 +31,7 @@
#:autoload (guix build syscalls) (terminal-columns)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
+ #:use-module ((ice-9 control) #:select (let/ec))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
@@ -55,6 +57,7 @@
nix-server-minor-version
nix-server-socket
current-store-protocol-version ;for internal use
+ mcached
&nix-error nix-error?
&nix-connection-error nix-connection-error?
@@ -332,10 +335,7 @@
;; remote-store.cc
-(define-record-type <nix-server>
- (%make-nix-server socket major minor
- buffer flush
- ats-cache atts-cache)
+(define-record-type* <nix-server> nix-server %make-nix-server
nix-server?
(socket nix-server-socket)
(major nix-server-major-version)
@@ -348,7 +348,9 @@
;; during the session are temporary GC roots kept for the duration of
;; the session.
(ats-cache nix-server-add-to-store-cache)
- (atts-cache nix-server-add-text-to-store-cache))
+ (atts-cache nix-server-add-text-to-store-cache)
+ (object-cache nix-server-object-cache
+ (default vlist-null))) ;vhash
(set-record-type-printer! <nix-server>
(lambda (obj port)
@@ -523,7 +525,8 @@ for this connection will be pinned. Return a server object."
(protocol-minor v)
output flush
(make-hash-table 100)
- (make-hash-table 100))))
+ (make-hash-table 100)
+ vlist-null)))
(let loop ((done? (process-stderr conn)))
(or done? (process-stderr conn)))
conn)))))))))
@@ -543,7 +546,8 @@ connection. Use with care."
(protocol-minor version)
output flush
(make-hash-table 100)
- (make-hash-table 100))))
+ (make-hash-table 100)
+ vlist-null)))
(define (nix-server-version store)
"Return the protocol version of STORE as an integer."
@@ -1486,6 +1490,56 @@ This makes sense only when the daemon was started with '--cache-failures'."
;; from %STATE-MONAD.
(template-directory instantiations %store-monad)
+(define* (cache-object-mapping object keys result)
+ "Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT.
+KEYS is a list of additional keys to match against, for instance a (SYSTEM
+TARGET) tuple.
+
+OBJECT is typically a high-level object such as a <package> or an <origin>,
+and RESULT is typically its derivation."
+ (lambda (store)
+ (values result
+ (nix-server
+ (inherit store)
+ (object-cache (vhash-consq object (cons result keys)
+ (nix-server-object-cache store)))))))
+
+(define* (lookup-cached-object object #:optional (keys '()))
+ "Return the cached object in the store connection corresponding to OBJECT
+and KEYS. KEYS is a list of additional keys to match against, and which are
+compared with 'equal?'. Return #f on failure and the cached result
+otherwise."
+ (lambda (store)
+ ;; Escape as soon as we find the result. This avoids traversing the whole
+ ;; vlist chain and significantly reduces the number of 'hashq' calls.
+ (values (let/ec return
+ (vhash-foldq* (lambda (item result)
+ (match item
+ ((value . keys*)
+ (if (equal? keys keys*)
+ (return value)
+ result))))
+ #f object
+ (nix-server-object-cache store)))
+ store)))
+
+(define* (%mcached mthunk object #:optional (keys '()))
+ "Bind the monadic value returned by MTHUNK, which supposedly corresponds to
+OBJECT/KEYS, or return its cached value."
+ (mlet %store-monad ((cached (lookup-cached-object object keys)))
+ (if cached
+ (return cached)
+ (>>= (mthunk)
+ (lambda (result)
+ (cache-object-mapping object keys result))))))
+
+(define-syntax-rule (mcached mvalue object keys ...)
+ "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the
+value associated with OBJECT/KEYS in the store's object cache if there is
+one."
+ (%mcached (lambda () mvalue)
+ object (list keys ...)))
+
(define (preserve-documentation original proc)
"Return PROC with documentation taken from ORIGINAL."
(set-object-property! proc 'documentation
diff --git a/guix/store/database.scm b/guix/store/database.scm
index 341276bc30..38796910da 100644
--- a/guix/store/database.scm
+++ b/guix/store/database.scm
@@ -36,7 +36,9 @@
#:use-module (ice-9 match)
#:use-module (system foreign)
#:export (sql-schema
+ %default-database-file
with-database
+ path-id
sqlite-register
register-path
register-items
@@ -85,6 +87,10 @@ create it and initialize it as a new database."
(lambda ()
(sqlite-close db)))))
+(define %default-database-file
+ ;; Default location of the store database.
+ (string-append %store-database-directory "/db.sqlite"))
+
(define-syntax-rule (with-database file db exp ...)
"Open DB from FILE and close it when the dynamic extent of EXP... is left.
If FILE doesn't exist, create it and initialize it as a new database."
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
index 53810c680f..21b0c81f3d 100644
--- a/guix/store/deduplication.scm
+++ b/guix/store/deduplication.scm
@@ -102,11 +102,17 @@ LINK-PREFIX."
SWAP-DIRECTORY as the directory to store temporary hard links.
Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system."
- (let ((temp-link (get-temp-link target swap-directory)))
- (make-file-writable (dirname to-replace))
+ (let* ((temp-link (get-temp-link target swap-directory))
+ (parent (dirname to-replace))
+ (stat (stat parent)))
+ (make-file-writable parent)
(catch 'system-error
(lambda ()
- (rename-file temp-link to-replace))
+ (rename-file temp-link to-replace)
+
+ ;; Restore PARENT's mtime and permissions.
+ (set-file-time parent stat)
+ (chmod parent (stat:mode stat)))
(lambda args
(delete-file temp-link)
(unless (= EMLINK (system-error-errno args))
diff --git a/guix/tests.scm b/guix/tests.scm
index bcf9b990e5..f4948148c4 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -27,6 +27,7 @@
#:use-module (guix build-system gnu)
#:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (web uri)
@@ -35,10 +36,13 @@
random-text
random-bytevector
file=?
+ canonical-file?
network-reachable?
shebang-too-long?
mock
%test-substitute-urls
+ test-assertm
+ test-equalm
%substitute-directory
with-derivation-narinfo
with-derivation-substitute
@@ -147,6 +151,14 @@ too expensive to build entirely in the test store."
(else
(error "what?" (lstat a))))))
+(define (canonical-file? file)
+ "Return #t if FILE is in the store, is read-only, and its mtime is 1."
+ (let ((st (lstat file)))
+ (or (not (string-prefix? (%store-prefix) file))
+ (eq? 'symlink (stat:type st))
+ (and (= 1 (stat:mtime st))
+ (zero? (logand #o222 (stat:mode st)))))))
+
(define (network-reachable?)
"Return true if we can reach the Internet."
(false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
@@ -161,6 +173,28 @@ given by REPLACEMENT."
(lambda () body ...)
(lambda () (module-set! m 'proc original)))))
+(define-syntax-rule (test-assertm name exp)
+ "Like 'test-assert', but EXP is a monadic value. A new connection to the
+store is opened."
+ (test-assert name
+ (let ((store (open-connection-for-tests)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (run-with-store store exp
+ #:guile-for-build (%guile-for-build)))
+ (lambda ()
+ (close-connection store))))))
+
+(define-syntax-rule (test-equalm name value exp)
+ "Like 'test-equal', but EXP is a monadic value. A new connection to the
+store is opened."
+ (test-equal name
+ value
+ (with-store store
+ (run-with-store store exp
+ #:guile-for-build (%guile-for-build)))))
+
;;;
;;; Narinfo files, as used by the substituter.