Merge branch 'master' into core-updates

6 files changed, 108 insertions, 75 deletions

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index adb62aa68c..0dd08bf535 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -48,7 +48,7 @@
             gnu-package-download-url
 
             official-gnu-packages
-            find-packages
+            find-package
             gnu-package?
 
             release-file?
@@ -155,13 +155,12 @@ to fetch the list of GNU packages over HTTP."
          (close-port port)
          lst)))
 
-(define (find-packages regexp)
-  "Find GNU packages which satisfy REGEXP."
-  (let ((name-rx (make-regexp regexp)))
-    (filter (lambda (package)
-              (false-if-exception
-               (regexp-exec name-rx (gnu-package-name package))))
-            (official-gnu-packages))))
+(define (find-package name)
+  "Find GNU package called NAME and return it.  Return #f if it was not
+found."
+  (find (lambda (package)
+          (string=? name (gnu-package-name package)))
+        (official-gnu-packages)))
 
 (define gnu-package?
   (memoize
diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm
index 2cfb46beb9..bbb17047f0 100644
--- a/guix/import/gnu.scm
+++ b/guix/import/gnu.scm
@@ -111,13 +111,13 @@ details.)"
   (match (latest-release name)
     ((? upstream-source? release)
      (let ((version (upstream-source-version release)))
-       (match (find-packages (regexp-quote name))
-         ((info . _)
-          (gnu-package->sexp info release #:key-download key-download))
-         (()
+       (match (find-package name)
+         (#f
           (raise (condition
                   (&message
-                   (message "couldn't find meta-data for GNU package"))))))))
+                   (message "couldn't find meta-data for GNU package")))))
+         (info
+          (gnu-package->sexp info release #:key-download key-download)))))
     (_
      (raise (condition
              (&message
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ce8a11fbe5..90c43325a0 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -469,7 +469,8 @@ MANIFEST that named NAME, or #f if not found."
     (with-monad %store-monad
       (match (manifest-entry-item entry)
         ((? package? package)
-         (match (package-transitive-inputs package)
+         (match (cons (list (package-name package) package)
+                      (package-transitive-inputs package))
            (((labels inputs . _) ...)
             (return (find-among-inputs inputs)))))
         ((? string? item)
@@ -509,9 +510,9 @@ MANIFEST."
                     info (string-append #$output "/share/info/dir"))))
 
         (mkdir-p (string-append #$output "/share/info"))
-        (every install-info
-               (append-map info-files
-                           '#$(manifest-inputs manifest)))))
+        (exit (every install-info
+                     (append-map info-files
+                                 '#$(manifest-inputs manifest))))))
 
   (gexp->derivation "info-dir" build
                     #:modules '((guix build utils))
@@ -561,7 +562,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
                 (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
                          (string-append "--package-db=" db-dir)))))
           (for-each delete-file (find-files db-dir "\\.conf$"))
-          success)))
+          (exit success))))
 
   (with-monad %store-monad
     ;; Don't depend on GHC when there's nothing to do.
@@ -709,7 +710,7 @@ MIME type."
             (mkdir-p (string-append #$output "/share"))
             (union-build destdir appdirs
                          #:log-port (%make-void-port "w"))
-            (zero? (system* update-desktop-database destdir)))))
+            (exit (zero? (system* update-desktop-database destdir))))))
 
     ;; Don't run the hook when 'desktop-file-utils' is not referenced.
     (if desktop-file-utils
@@ -733,18 +734,18 @@ entries.  It's used to query the MIME type of a given file."
                        (guix build union))
           (let* ((datadir (string-append #$output "/share"))
                  (destdir (string-append datadir "/mime"))
-                 (mimedirs (filter file-exists?
-                                   (map (cut string-append <>
-                                             "/share/mime")
-                                        '#$(manifest-inputs manifest))))
+                 (pkgdirs (filter file-exists?
+                                  (map (cut string-append <>
+                                            "/share/mime/packages")
+                                       '#$(manifest-inputs manifest))))
                  (update-mime-database (string-append
                                         #+shared-mime-info
                                         "/bin/update-mime-database")))
-            (mkdir-p datadir)
-         (union-build destdir mimedirs
-                      #:log-port (%make-void-port "w"))
-         (setenv "XDG_DATA_HOME" datadir)
-         (zero? (system* update-mime-database destdir)))))
+            (mkdir-p destdir)
+            (union-build (string-append destdir "/packages") pkgdirs
+                         #:log-port (%make-void-port "w"))
+            (setenv "XDG_DATA_HOME" datadir)
+            (exit (zero? (system* update-mime-database destdir))))))
 
     ;; Don't run the hook when 'shared-mime-info' is referenced.
     (if shared-mime-info
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 46292131d7..4c0aa8e419 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -28,6 +28,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (web http)
@@ -58,6 +59,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (_ "
   -u, --user=USER        change privileges to USER as soon as possible"))
   (display (_ "
+      --ttl=TTL          announce narinfos can be cached for TTL seconds"))
+  (display (_ "
   -r, --repl[=PORT]      spawn REPL server on PORT"))
   (newline)
   (display (_ "
@@ -99,6 +102,13 @@ Publish ~a over HTTP.\n") %store-directory)
                     (()
                      (leave (_ "lookup of host '~a' returned nothing")
                             name)))))
+        (option '("ttl") #t #f
+                (lambda (opt name arg result)
+                  (let ((duration (string->duration arg)))
+                    (unless duration
+                      (leave (_ "~a: invalid duration~%") arg))
+                    (alist-cons 'narinfo-ttl (time-second duration)
+                                result))))
         (option '(#\r "repl") #f #t
                 (lambda (opt name arg result)
                   ;; If port unspecified, use default Guile REPL port.
@@ -146,7 +156,8 @@ Publish ~a over HTTP.\n") %store-directory)
   "Generate a narinfo key/value string for STORE-PATH; an exception is raised
 if STORE-PATH is invalid.  The narinfo is signed with KEY."
   (let* ((path-info  (query-path-info store store-path))
-         (url        (string-append "nar/" (basename store-path)))
+         (url        (encode-and-join-uri-path (list "nar"
+                                                     (basename store-path))))
          (hash       (bytevector->nix-base32-string
                       (path-info-hash path-info)))
          (size       (path-info-nar-size path-info))
@@ -198,12 +209,18 @@ References: ~a~%"
                         (format port "~a: ~a~%" key value)))
                       %nix-cache-info))))
 
-(define (render-narinfo store request hash)
-  "Render metadata for the store path corresponding to HASH."
+(define* (render-narinfo store request hash #:key ttl)
+  "Render metadata for the store path corresponding to HASH.  If TTL is true,
+advertise it as the maximum validity period (in seconds) via the
+'Cache-Control' header.  This allows 'guix substitute' to cache it for an
+appropriate duration."
   (let ((store-path (hash-part->path store hash)))
     (if (string-null? store-path)
         (not-found request)
-        (values '((content-type . (application/x-nix-narinfo)))
+        (values `((content-type . (application/x-nix-narinfo))
+                  ,@(if ttl
+                        `((cache-control (max-age . ,ttl)))
+                        '()))
                 (cut display
                      (narinfo-string store store-path (force %private-key))
                      <>)))))
@@ -299,7 +316,7 @@ blocking."
   http-write
   (@@ (web server http) http-close))
 
-(define (make-request-handler store)
+(define* (make-request-handler store #:key narinfo-ttl)
   (lambda (request body)
     (format #t "~a ~a~%"
             (request-method request)
@@ -311,15 +328,18 @@ blocking."
            (render-nix-cache-info))
           ;; /<hash>.narinfo
           (((= extract-narinfo-hash (? string? hash)))
-           (render-narinfo store request hash))
+           ;; TODO: Register roots for HASH that will somehow remain for
+           ;; NARINFO-TTL.
+           (render-narinfo store request hash #:ttl narinfo-ttl))
           ;; /nar/<store-item>
           (("nar" store-item)
            (render-nar store request store-item))
           (_ (not-found request)))
         (not-found request))))
 
-(define (run-publish-server socket store)
-  (run-server (make-request-handler store)
+(define* (run-publish-server socket store
+                             #:key narinfo-ttl)
+  (run-server (make-request-handler store #:narinfo-ttl narinfo-ttl)
               concurrent-http-server
               `(#:socket ,socket)))
 
@@ -357,6 +377,7 @@ blocking."
                                 %default-options))
            (user    (assoc-ref opts 'user))
            (port    (assoc-ref opts 'port))
+           (ttl     (assoc-ref opts 'narinfo-ttl))
            (address (let ((addr (assoc-ref opts 'address)))
                       (make-socket-address (sockaddr:fam addr)
                                            (sockaddr:addr addr)
@@ -383,4 +404,4 @@ consider using the '--user' option!~%")))
       (when repl-port
         (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
       (with-store store
-        (run-publish-server socket store)))))
+        (run-publish-server socket store #:narinfo-ttl ttl)))))
diff --git a/guix/serialization.scm b/guix/serialization.scm
index 286b4cbf30..f17f516c09 100644
--- a/guix/serialization.scm
+++ b/guix/serialization.scm
@@ -256,53 +256,57 @@ the size in bytes."
   ;; Magic cookie for Nix archives.
   "nix-archive-1")
 
-(define (write-file file port)
+(define* (write-file file port
+                     #:key (select? (const #t)))
   "Write the contents of FILE to PORT in Nar format, recursing into
-sub-directories of FILE as needed."
+sub-directories of FILE as needed.  For each directory entry, call (SELECT?
+FILE STAT), where FILE is the entry's absolute file name and STAT is the
+result of 'lstat'; exclude entries for which SELECT? does not return true."
   (define p port)
 
   (write-string %archive-version-1 p)
 
-  (let dump ((f file))
-    (let ((s (lstat f)))
-      (write-string "(" p)
-      (case (stat:type s)
-        ((regular)
-         (write-string "type" p)
-         (write-string "regular" p)
-         (if (not (zero? (logand (stat:mode s) #o100)))
-             (begin
-               (write-string "executable" p)
-               (write-string "" p)))
-         (write-contents f p (stat:size s)))
-        ((directory)
-         (write-string "type" p)
-         (write-string "directory" p)
-         (let ((entries
-                ;; 'scandir' defaults to 'string-locale<?' to sort files, but
-                ;; this happens to be case-insensitive (at least in 'en_US'
-                ;; locale on libc 2.18.)  Conversely, we want files to be
-                ;; sorted in a case-sensitive fashion.
-                (scandir f (negate (cut member <> '("." ".."))) string<?)))
-           (for-each (lambda (e)
-                       (let ((f (string-append f "/" e)))
+  (let dump ((f file) (s (lstat file)))
+    (write-string "(" p)
+    (case (stat:type s)
+      ((regular)
+       (write-string "type" p)
+       (write-string "regular" p)
+       (if (not (zero? (logand (stat:mode s) #o100)))
+           (begin
+             (write-string "executable" p)
+             (write-string "" p)))
+       (write-contents f p (stat:size s)))
+      ((directory)
+       (write-string "type" p)
+       (write-string "directory" p)
+       (let ((entries
+              ;; 'scandir' defaults to 'string-locale<?' to sort files, but
+              ;; this happens to be case-insensitive (at least in 'en_US'
+              ;; locale on libc 2.18.)  Conversely, we want files to be
+              ;; sorted in a case-sensitive fashion.
+              (scandir f (negate (cut member <> '("." ".."))) string<?)))
+         (for-each (lambda (e)
+                     (let* ((f (string-append f "/" e))
+                            (s (lstat f)))
+                       (when (select? f s)
                          (write-string "entry" p)
                          (write-string "(" p)
                          (write-string "name" p)
                          (write-string e p)
                          (write-string "node" p)
-                         (dump f)
-                         (write-string ")" p)))
-                     entries)))
-        ((symlink)
-         (write-string "type" p)
-         (write-string "symlink" p)
-         (write-string "target" p)
-         (write-string (readlink f) p))
-        (else
-         (raise (condition (&message (message "unsupported file type"))
-                           (&nar-error (file f) (port port))))))
-      (write-string ")" p))))
+                         (dump f s)
+                         (write-string ")" p))))
+                   entries)))
+      ((symlink)
+       (write-string "type" p)
+       (write-string "symlink" p)
+       (write-string "target" p)
+       (write-string (readlink f) p))
+      (else
+       (raise (condition (&message (message "unsupported file type"))
+                         (&nar-error (file f) (port port))))))
+    (write-string ")" p)))
 
 (define (restore-file port file)
   "Read a file (possibly a directory structure) in Nar format from PORT.
diff --git a/guix/ui.scm b/guix/ui.scm
index cbc9dc841a..4d1b65cb8a 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -968,7 +968,15 @@ following patterns: \"1d\", \"1w\", \"1m\"."
     (make-time time-duration 0
                (* 3600 hours (string->number (match:substring match 1)))))
 
-  (cond ((string-match "^([0-9]+)d$" str)
+  (cond ((string-match "^([0-9]+)s$" str)
+         =>
+         (lambda (match)
+           (make-time time-duration 0
+                      (string->number (match:substring match 1)))))
+        ((string-match "^([0-9]+)h$" str)
+         (lambda (match)
+           (hours->duration 1 match)))
+        ((string-match "^([0-9]+)d$" str)
          =>
          (lambda (match)
            (hours->duration 24 match)))