Merge branch 'master' into core-updates

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.