From dc794a723809f0f28e49e4c32e8974b5b9a98ff0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Jun 2016 17:59:45 +0200 Subject: gnu-maintenance: Replace 'find-packages' with 'find-package' (singular). Fixes . Reported by Efraim Flashner . * guix/gnu-maintenance.scm (find-packages): Remove. (find-package): New procedure. * guix/import/gnu.scm (gnu->guix-package): Use 'find-package' instead of 'find-packages' and adjust accordingly. --- guix/gnu-maintenance.scm | 15 +++++++-------- guix/import/gnu.scm | 10 +++++----- 2 files changed, 12 insertions(+), 13 deletions(-) (limited to 'guix') 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 @@ (define-module (guix gnu-maintenance) gnu-package-download-url official-gnu-packages - find-packages + find-package gnu-package? release-file? @@ -155,13 +155,12 @@ (define official-description (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 @@ (define* (gnu->guix-package name (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 -- cgit v1.2.3 From 93961f02987cf738d116cc85cc32d97c2a488222 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Jun 2016 18:59:25 +0200 Subject: publish: Encore URIs that appear in narinfos. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by iyzsong@member.fsf.org (宋文武). * guix/scripts/publish.scm (narinfo-string): Use 'encode-and-join-uri-path' instead of 'string-append' to compute URL. * tests/publish.scm ("/*.narinfo with properly encoded '+' sign"): ("/nar/ with properly encoded '+' sign"): New tests. --- guix/scripts/publish.scm | 3 ++- tests/publish.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 46292131d7..ddb579bb17 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -146,7 +146,8 @@ (define (narinfo-string store store-path key) "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)) diff --git a/tests/publish.scm b/tests/publish.scm index 6645286f5a..d6d537c58a 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -30,12 +30,14 @@ (define-module (test-publish) #:use-module (guix base64) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix pk-crypto) + #:use-module (web uri) #:use-module (web client) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 rdelim)) @@ -101,6 +103,37 @@ (define (publish-uri route) (publish-uri (string-append "/" (store-path-hash-part %item) ".narinfo"))))) +(test-equal "/*.narinfo with properly encoded '+' sign" + ;; See . + (let* ((item (add-text-to-store %store "fake-gtk+" "Congrats!")) + (info (query-path-info %store item)) + (unsigned-info + (format #f + "StorePath: ~a +URL: nar/~a +Compression: none +NarHash: sha256:~a +NarSize: ~d +References: ~%" + item + (uri-encode (basename item)) + (bytevector->nix-base32-string + (path-info-hash info)) + (path-info-nar-size info))) + (signature (base64-encode + (string->utf8 + (canonical-sexp->string + ((@@ (guix scripts publish) signed-string) + unsigned-info)))))) + (format #f "~aSignature: 1;~a;~a~%" + unsigned-info (gethostname) signature)) + + (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) + (utf8->string + (http-get-body + (publish-uri + (string-append "/" (store-path-hash-part item) ".narinfo")))))) + (test-equal "/nar/*" "bar" (call-with-temporary-output-file @@ -112,6 +145,18 @@ (define (publish-uri route) (call-with-input-string nar (cut restore-file <> temp))) (call-with-input-file temp read-string)))) +(test-equal "/nar/ with properly encoded '+' sign" + "Congrats!" + (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!"))) + (call-with-temporary-output-file + (lambda (temp port) + (let ((nar (utf8->string + (http-get-body + (publish-uri + (string-append "/nar/" (uri-encode (basename item)))))))) + (call-with-input-string nar (cut restore-file <> temp))) + (call-with-input-file temp read-string))))) + (test-equal "/nar/invalid" 404 (begin -- cgit v1.2.3 From 638c5b79397aba92ab3211a1ea3b3418e112ec66 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Jun 2016 23:28:17 +0200 Subject: ui: 'string->duration' supports hours and seconds. * guix/ui.scm (string->duration): Add seconds and hours. * tests/ui.scm ("duration, 1 second"): New test. --- guix/ui.scm | 10 +++++++++- tests/ui.scm | 6 +++++- 2 files changed, 14 insertions(+), 2 deletions(-) (limited to 'guix') 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 @@ (define (hours->duration hours match) (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))) diff --git a/tests/ui.scm b/tests/ui.scm index 51577acb76..058207e8b9 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -189,6 +189,10 @@ (define guile-2.0.9 (string->duration "1m") (string->duration "30d")) +(test-equal "duration, 1 second" + (make-time time-duration 0 1) + (string->duration "1s")) + (test-equal "duration, integer" #f (string->duration "1")) -- cgit v1.2.3 From e4c7a5f7c87b2927f1092108f181f44c96377633 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Jun 2016 23:33:20 +0200 Subject: publish: Add '--ttl'. * guix/scripts/publish.scm (show-help, %options): Add --ttl. (render-narinfo): Add #:ttl and honor it. (make-request-handler): Add #:narinfo-ttl and honor it. (run-publish-server): Likewise. (guix-publish): Honor --ttl, pass it to 'run-publish-server'. --- doc/guix.texi | 10 ++++++++++ guix/scripts/publish.scm | 36 ++++++++++++++++++++++++++++-------- 2 files changed, 38 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 9b36468557..1f766fc13b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5545,6 +5545,16 @@ accept connections from any interface. Change privileges to @var{user} as soon as possible---i.e., once the server socket is open and the signing key has been read. +@item --ttl=@var{ttl} +Produce @code{Cache-Control} HTTP headers that advertise a time-to-live +(TTL) of @var{ttl}. @var{ttl} must denote a duration: @code{5d} means 5 +days, @code{1m} means 1 month, and so on. + +This allows the user's Guix to keep substitute information in cache for +@var{ttl}. However, note that @code{guix publish} does not itself +guarantee that the store items it provides will indeed remain available +for as long as @var{ttl}. + @item --repl[=@var{port}] @itemx -r [@var{port}] Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ddb579bb17..4c0aa8e419 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -28,6 +28,7 @@ (define-module (guix scripts publish) #: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) @@ -57,6 +58,8 @@ (define (show-help) --listen=HOST listen on the network interface for HOST")) (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) @@ -99,6 +102,13 @@ (define %options (() (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. @@ -199,12 +209,18 @@ (define (render-nix-cache-info) (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)) <>))))) @@ -300,7 +316,7 @@ (define-server-impl concurrent-http-server 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) @@ -312,15 +328,18 @@ (define (make-request-handler store) (render-nix-cache-info)) ;; /.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/ (("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))) @@ -358,6 +377,7 @@ (define (guix-publish . args) %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) @@ -384,4 +404,4 @@ (define (guix-publish . args) (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))))) -- cgit v1.2.3 From 359f06aac8e6aaab96b68a0497224c00b622c193 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Sat, 11 Jun 2016 09:57:11 +0800 Subject: profiles: xdg-mime-database: Union the "share/mime/packages" directory. * guix/profiles.scm (xdg-mime-database): Call 'union-build' for the "share/mime/packages" directory of inputs. --- guix/profiles.scm | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index ce8a11fbe5..3cb7b7a3ed 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -733,18 +733,18 @@ (define build (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) + (zero? (system* update-mime-database destdir))))) ;; Don't run the hook when 'shared-mime-info' is referenced. (if shared-mime-info -- cgit v1.2.3 From 963521a3804893ec22a5cd7614791aa2925daa7b Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Sat, 11 Jun 2016 10:29:45 +0800 Subject: profiles: manifest-lookup-package: Correctly handle package entries. * guix/profiles.scm (manifest-lookup-package): Consider the package entry in addition to its 'package-transitive-inputs'. --- guix/profiles.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 3cb7b7a3ed..37ea302e82 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -469,7 +469,8 @@ (define references* (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) -- cgit v1.2.3 From 4d4c3614c85f98f734b3e4f375568b562dd1e2a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 12 Jun 2016 22:33:07 +0200 Subject: profiles: Make sure hook derivations fail upon error. Reported at . * guix/profiles.scm (info-dir-file)[build]: Add explicit call to 'exit'. * guix/profiles.scm (ghc-package-cache-file)[build]: Likewise. * guix/profiles.scm (xdg-desktop-database)[build]: Likewise. * guix/profiles.scm (xdg-mime-database)[build]: Likewise. --- guix/profiles.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 37ea302e82..90c43325a0 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -510,9 +510,9 @@ (define (install-info info) 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)) @@ -562,7 +562,7 @@ (define (copy-conf-file conf) (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. @@ -710,7 +710,7 @@ (define build (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 @@ -745,7 +745,7 @@ (define build (union-build (string-append destdir "/packages") pkgdirs #:log-port (%make-void-port "w")) (setenv "XDG_DATA_HOME" datadir) - (zero? (system* update-mime-database destdir))))) + (exit (zero? (system* update-mime-database destdir)))))) ;; Don't run the hook when 'shared-mime-info' is referenced. (if shared-mime-info -- cgit v1.2.3 From fe585be9aa8f5158a7dfb6477d19ece3d643dec3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 12 Jun 2016 23:22:54 +0200 Subject: serialization: Add #:select? parameter to 'write-file'. * guix/serialization.scm (write-file): Add #:select? parameter and honor it. * tests/nar.scm ("write-file #:select? + restore-file"): New test. --- guix/serialization.scm | 78 ++++++++++++++++++++++++++------------------------ tests/nar.scm | 42 ++++++++++++++++++++++++++- 2 files changed, 82 insertions(+), 38 deletions(-) (limited to 'guix') 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 @@ (define %archive-version-1 ;; 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 '("." ".."))) string '("." ".."))) string +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -241,6 +241,46 @@ (define (touch file) (lambda () (rmdir input))))) +(test-assert "write-file #:select? + restore-file" + (let ((input (string-append %test-dir ".input"))) + (mkdir input) + (dynamic-wind + (const #t) + (lambda () + (with-file-tree input + (directory "root" + ((directory "a" (("x") ("y") ("z"))) + ("b") ("c") ("d" -> "b"))) + (let* ((output %test-dir) + (nar (string-append output ".nar"))) + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-output-file nar + (lambda (port) + (write-file input port + #:select? + (lambda (file stat) + (and (not (string=? (basename file) + "a")) + (not (eq? (stat:type stat) + 'symlink))))))) + (call-with-input-file nar + (cut restore-file <> output)) + + ;; Make sure "a" and "d" have been filtered out. + (and (not (file-exists? (string-append output "/root/a"))) + (file=? (string-append output "/root/b") + (string-append input "/root/b")) + (file=? (string-append output "/root/c") + (string-append input "/root/c")) + (not (file-exists? (string-append output "/root/d"))))) + (lambda () + (false-if-exception (delete-file nar)) + (false-if-exception (rm-rf output))))))) + (lambda () + (rmdir input))))) + ;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn ;; relies on a Guile 2.0.10+ feature. (test-skip (if (false-if-exception -- cgit v1.2.3