From 2e3e5d21988fc2cafb2a9eaf4b00976ea425629d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Sep 2019 21:36:29 +0200 Subject: daemon: Invoke 'guix gc --list-busy' instead of 'list-runtime-roots'. * nix/scripts/list-runtime-roots.in: Remove. * guix/store/roots.scm (%proc-directory): New variable. (proc-file-roots, proc-exe-roots, proc-cwd-roots) (proc-fd-roots, proc-maps-roots, proc-environ-roots) (referenced-files, canonicalize-store-item, busy-store-items): New procedures, taken from 'list-runtime-roots.in'. * nix/libstore/globals.hh (Settings)[guixProgram]: New field. * nix/libstore/globals.cc (Settings::processEnvironment): Initialize 'guixProgram'. * nix/libstore/gc.cc (addAdditionalRoots): Drop code related to 'NIX_ROOT_FINDER'. Run "guix gc --list-busy". * nix/local.mk (nodist_pkglibexec_SCRIPTS): Remove 'scripts/list-runtime-roots'. * config-daemon.ac: Don't output nix/scripts/list-runtime-roots. * build-aux/pre-inst-env.in: Don't set 'NIX_ROOT_FINDER'. Set 'GUIX'. * doc/guix.texi (Invoking guix gc): Document '--list-busy'. * guix/scripts/gc.scm (show-help, %options): Add "--list-busy". (guix-gc)[list-busy]: New procedure. Handle the 'list-busy' action. --- guix/scripts/gc.scm | 15 ++++++ guix/store/roots.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 142 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 31657326b6..3f20a2e192 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -56,6 +56,8 @@ Invoke the garbage collector.\n")) -D, --delete attempt to delete PATHS")) (display (G_ " --list-roots list the user's garbage collector roots")) + (display (G_ " + --list-busy list store items used by running processes")) (display (G_ " --optimize optimize the store by deduplicating identical files")) (display (G_ " @@ -174,6 +176,10 @@ is deprecated; use '-D'~%")) (lambda (opt name arg result) (alist-cons 'action 'list-roots (alist-delete 'action result)))) + (option '("list-busy") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-busy + (alist-delete 'action result)))) (option '("list-dead") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-dead @@ -265,6 +271,12 @@ is deprecated; use '-D'~%")) (newline)) roots))) + (define (list-busy) + ;; List store items used by running processes. + (for-each (lambda (item) + (display item) (newline)) + (busy-store-items))) + (with-error-handling (let* ((opts (parse-options)) (store (open-connection)) @@ -305,6 +317,9 @@ is deprecated; use '-D'~%")) ((list-roots) (assert-no-extra-arguments) (list-roots)) + ((list-busy) + (assert-no-extra-arguments) + (list-busy)) ((delete) (delete-paths store (map direct-store-path paths))) ((list-references) diff --git a/guix/store/roots.scm b/guix/store/roots.scm index 4f23ae34e8..58653507f8 100644 --- a/guix/store/roots.scm +++ b/guix/store/roots.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,9 +26,13 @@ #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (rnrs io ports) #:re-export (%gc-roots-directory) #:export (gc-roots - user-owned?)) + user-owned? + busy-store-items)) ;;; Commentary: ;;; @@ -118,3 +122,124 @@ are user-controlled symlinks stored anywhere on the file system." (= (stat:uid stat) uid)) (const #f))) + + +;;; +;;; Listing "busy" store items: those referenced by currently running +;;; processes. +;;; + +(define %proc-directory + ;; Mount point of Linuxish /proc file system. + "/proc") + +(define (proc-file-roots dir file) + "Return a one-element list containing the file pointed to by DIR/FILE, +or the empty list." + (or (and=> (false-if-exception (readlink (string-append dir "/" file))) + list) + '())) + +(define proc-exe-roots (cut proc-file-roots <> "exe")) +(define proc-cwd-roots (cut proc-file-roots <> "cwd")) + +(define (proc-fd-roots dir) + "Return the list of store files referenced by DIR, which is a +/proc/XYZ directory." + (let ((dir (string-append dir "/fd"))) + (filter-map (lambda (file) + (let ((target (false-if-exception + (readlink (string-append dir "/" file))))) + (and target + (string-prefix? "/" target) + target))) + (or (scandir dir string->number) '())))) + +(define (proc-maps-roots dir) + "Return the list of store files referenced by DIR, which is a +/proc/XYZ directory." + (define %file-mapping-line + (make-regexp "^.*[[:blank:]]+/([^ ]+)$")) + + (call-with-input-file (string-append dir "/maps") + (lambda (maps) + (let loop ((line (read-line maps)) + (roots '())) + (cond ((eof-object? line) + roots) + ((regexp-exec %file-mapping-line line) + => + (lambda (match) + (let ((file (string-append "/" + (match:substring match 1)))) + (loop (read-line maps) + (cons file roots))))) + (else + (loop (read-line maps) roots))))))) + +(define (proc-environ-roots dir) + "Return the list of store files referenced by DIR/environ, where DIR is a +/proc/XYZ directory." + (define split-on-nul + (cute string-tokenize <> + (char-set-complement (char-set #\nul)))) + + (define (rhs-file-names str) + (let ((equal (string-index str #\=))) + (if equal + (let* ((str (substring str (+ 1 equal))) + (rx (string-append (regexp-quote %store-directory) + "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+"))) + (map match:substring (list-matches rx str))) + '()))) + + (define environ + (string-append dir "/environ")) + + (append-map rhs-file-names + (split-on-nul + (call-with-input-file environ + get-string-all)))) + +(define (referenced-files) + "Return the list of referenced store items." + (append-map (lambda (pid) + (let ((proc (string-append %proc-directory "/" pid))) + (catch 'system-error + (lambda () + (append (proc-exe-roots proc) + (proc-cwd-roots proc) + (proc-fd-roots proc) + (proc-maps-roots proc) + (proc-environ-roots proc))) + (lambda args + (let ((err (system-error-errno args))) + (if (or (= ENOENT err) ;TOCTTOU race + (= ESRCH err) ;ditto + (= EACCES err)) ;not running as root + '() + (apply throw args))))))) + (scandir %proc-directory string->number + (lambda (a b) + (< (string->number a) (string->number b)))))) + +(define canonicalize-store-item + (let* ((store (string-append %store-directory "/")) + (prefix (string-length store))) + (lambda (file) + "Return #f if FILE is not a store item; otherwise, return the store file +name without any sub-directory components." + (and (string-prefix? store file) + (string-append store + (let ((base (string-drop file prefix))) + (match (string-index base #\/) + (#f base) + (slash (string-take base slash))))))))) + +(define (busy-store-items) + "Return the list of store items used by the currently running processes. + +This code should typically run as root; it allows the garbage collector to +determine which store items must not be deleted." + (delete-duplicates + (filter-map canonicalize-store-item (referenced-files)))) -- cgit v1.2.3 From 982a94e97eff85b053558fac7c0442726a091f11 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 8 Sep 2019 14:29:27 +0200 Subject: import: github: Fix incorrect no-release case. This is a followup to 81c3dc32244a17241d74eea9fa265edfcb326f6d. Since that commit, when /releases returned an empty JSON array, we would not fall back to /tags because of the incorrect match. * guix/import/github.scm (fetch-releases-or-tags): Match the empty vector instead of the empty list. --- guix/import/github.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index 55e1f72a42..55ea00a111 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -161,7 +161,7 @@ empty list." url)) (match (json-fetch (decorate release-url) #:headers headers) - (() + (#() ;; We got the empty list, presumably because the user didn't use GitHub's ;; "release" mechanism, but hopefully they did use Git tags. (json-fetch (decorate tag-url) #:headers headers)) -- cgit v1.2.3 From 36eef80d45ae754ba42a761ffc97e38cc7253bd0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 9 Sep 2019 10:19:59 +0200 Subject: packages: 'package-field-location' really catches 'system-error. This had been wrong since forever (i.e., 2013). * guix/packages.scm (package-field-location): Catch 'system-error, not 'system. --- guix/packages.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 143417b861..b92ed0ab0c 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -351,7 +351,7 @@ object." (match (package-location package) (($ file line column) - (catch 'system + (catch 'system-error (lambda () ;; In general we want to keep relative file names for modules. (with-fluids ((%file-port-name-canonicalization 'relative)) -- cgit v1.2.3 From 7c101c4c175b7abcb43279d1c66b41a91b9c64bc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 9 Sep 2019 10:33:42 +0200 Subject: refresh: Distinguish between "no updater" and "failing updater". Previously, something like "guix refresh texmacs" would report "no updater". Now, it reports that the 'gnu-ftp' updater failed to list releases. * guix/upstream.scm (lookup-updater): Use 'find' instead of 'any' to return the . (package-latest-release): Adjust accordingly. * guix/scripts/refresh.scm (check-for-package-update): When 'package-latest-release' returns #f, distinguish between "no updater" and "failing updater". --- guix/scripts/refresh.scm | 12 ++++++++++-- guix/upstream.scm | 12 ++++++------ 2 files changed, 16 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 4591d0f308..daf6fcf947 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -368,8 +368,16 @@ the latest known version of ~a (~a)~%") (upstream-source-version source))))))) (#f (when warn? - (warn-no-updater package))))) - + ;; Distinguish between "no updater" and "failing updater." + (match (lookup-updater package updaters) + ((? upstream-updater? updater) + (warning (package-location package) + (G_ "'~a' updater failed to determine available \ +releases for ~a~%") + (upstream-updater-name updater) + (package-name package))) + (#f + (warn-no-updater package))))))) ;;; diff --git a/guix/upstream.scm b/guix/upstream.scm index d4f9c5bb45..aa47dab4b4 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -245,18 +245,18 @@ correspond to the same version." (define (lookup-updater package updaters) "Return an updater among UPDATERS that matches PACKAGE, or #f if none of them matches." - (any (match-lambda - (($ name description pred latest) - (and (pred package) latest))) - updaters)) + (find (match-lambda + (($ name description pred latest) + (pred package))) + updaters)) (define (package-latest-release package updaters) "Return an upstream source to update PACKAGE, a object, or #f if none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure that the returned source is newer than the current one." (match (lookup-updater package updaters) - ((? procedure? latest-release) - (latest-release package)) + ((? upstream-updater? updater) + ((upstream-updater-latest updater) package)) (_ #f))) (define (package-latest-release* package updaters) -- cgit v1.2.3 From fd63ecbe050bf8fa7c8ff0a003d56cce97b6ded1 Mon Sep 17 00:00:00 2001 From: Martin Becze Date: Mon, 9 Sep 2019 11:36:04 -0400 Subject: import: crate: Allow imports of a specific version. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/crate.scm (crate->guix-package): Add optional 'version' argument and honor it. * guix/scripts/import/crate.scm (guix-import-crate): Assume the first argument is a spec and destructure it with 'package-name->name+version'. Pass both to 'crate->guix-package'. * doc/guix.texi (Invoking guix import): Document it. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 12 +++++++++++- guix/import/crate.scm | 29 +++++++++++++++++++---------- guix/scripts/import/crate.scm | 13 ++++++++++--- 3 files changed, 40 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 9101aafda1..989b3d03bb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8912,7 +8912,17 @@ in Guix. @item crate @cindex crate Import metadata from the crates.io Rust package repository -@uref{https://crates.io, crates.io}. +@uref{https://crates.io, crates.io}, as in this example: + +@example +guix import crate blake2-rfc +@end example + +The crate importer also allows you to specify a version string: + +@example +guix import crate constant-time-eq@@0.1.0 +@end example @item opam @cindex OPAM diff --git a/guix/import/crate.scm b/guix/import/crate.scm index f6057dbf8b..fd1974eae8 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven ;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -181,9 +182,11 @@ and LICENSE." ;; This regexp matches that. (make-regexp "^(.*) OR (.*)$")) -(define (crate->guix-package crate-name) +(define* (crate->guix-package crate-name #:optional version) "Fetch the metadata for CRATE-NAME from crates.io, and return the -`package' s-expression corresponding to that package, or #f on failure." +`package' s-expression corresponding to that package, or #f on failure. +When VERSION is specified, attempt to fetch that version; otherwise fetch the +latest version of CRATE-NAME." (define (string->license string) (match (regexp-exec %dual-license-rx string) (#f (list (spdx-string->license string))) @@ -196,12 +199,18 @@ and LICENSE." (define crate (lookup-crate crate-name)) - (and crate - (let* ((version (find (lambda (version) - (string=? (crate-version-number version) - (crate-latest-version crate))) - (crate-versions crate))) - (dependencies (crate-version-dependencies version)) + (define version-number + (or version + (crate-latest-version crate))) + + (define version* + (find (lambda (version) + (string=? (crate-version-number version) + version-number)) + (crate-versions crate))) + + (and crate version* + (let* ((dependencies (crate-version-dependencies version*)) (dep-crates (filter normal-dependency? dependencies)) (dev-dep-crates (remove normal-dependency? dependencies)) (cargo-inputs (sort (map crate-dependency-id dep-crates) @@ -210,14 +219,14 @@ and LICENSE." (sort (map crate-dependency-id dev-dep-crates) string-ci (crate-version-license version) + #:license (and=> (crate-version-license version*) string->license))))) (define (guix-package->crate-name package) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index cab9a4397b..7ae8638911 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -2,6 +2,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2016 David Craven +;;; Copyright © 2019 Martin Becze ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,6 +76,7 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (alist-cons 'argument arg result)) %default-options)) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -82,11 +84,16 @@ Import and convert the crate.io package for PACKAGE-NAME.\n")) (_ #f)) (reverse opts)))) (match args - ((package-name) - (let ((sexp (crate->guix-package package-name))) + ((spec) + (define-values (name version) + (package-name->name+version spec)) + + (let ((sexp (crate->guix-package name version))) (unless sexp (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) + (if version + (string-append name "@" version) + name))) sexp)) (() (leave (G_ "too few arguments~%"))) -- cgit v1.2.3 From da1027a70508ea96134f5ef89d9dd390679255f0 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Tue, 27 Aug 2019 18:20:16 +0200 Subject: guix: Rename and move sans-extension to tarball-sans-extension. * guix/gnu-maintenance.scm (sans-extension): Move and rename to ... * guix/utils.scm (tarball-sans-extension): ... here. --- guix/gnu-maintenance.scm | 26 ++++++++++++-------------- guix/utils.scm | 7 +++++++ 2 files changed, 19 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index d63d44f629..8fce956c60 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -230,12 +230,6 @@ network to check in GNU's database." (or (assoc-ref (package-properties package) 'ftp-directory) (string-append "/gnu/" name))))) -(define (sans-extension tarball) - "Return TARBALL without its .tar.* or .zip extension." - (let ((end (or (string-contains tarball ".tar") - (string-contains tarball ".zip")))) - (substring tarball 0 end))) - (define %tarball-rx ;; The .zip extensions is notably used for freefont-ttf. ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". @@ -261,14 +255,15 @@ true." (string-append project "-src"))))))) (not (regexp-exec %alpha-tarball-rx file)) - (let ((s (sans-extension file))) + (let ((s (tarball-sans-extension file))) (regexp-exec %package-name-rx s)))) (define (tarball->version tarball) "Return the version TARBALL corresponds to. TARBALL is a file name like \"coreutils-8.23.tar.xz\"." (let-values (((name version) - (gnu-package-name->name+version (sans-extension tarball)))) + (gnu-package-name->name+version + (tarball-sans-extension tarball)))) version)) (define* (releases project @@ -492,8 +487,9 @@ return the corresponding signature URL, or #f it signatures are unavailable." (and (string=? url (basename url)) ;relative reference? (release-file? package url) (let-values (((name version) - (package-name->name+version (sans-extension url) - #\-))) + (package-name->name+version + (tarball-sans-extension url) + #\-))) (upstream-source (package name) (version version) @@ -565,14 +561,16 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)." (release-file? name (basename file)))) files))) (match (sort relevant (lambda (file1 file2) - (version>? (sans-extension (basename file1)) - (sans-extension (basename file2))))) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) ((and tarballs (reference _ ...)) (let* ((version (tarball->version reference)) (tarballs (filter (lambda (file) - (string=? (sans-extension + (string=? (tarball-sans-extension (basename file)) - (sans-extension + (tarball-sans-extension (basename reference)))) tarballs))) (upstream-source diff --git a/guix/utils.scm b/guix/utils.scm index f480c3291f..1f99c5b3f5 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -91,6 +91,7 @@ arguments-from-environment-variable file-extension file-sans-extension + tarball-sans-extension compressed-file? switch-symlinks call-with-temporary-output-file @@ -578,6 +579,12 @@ minor version numbers from version-string." (substring file 0 dot) file))) +(define (tarball-sans-extension tarball) + "Return TARBALL without its .tar.* or .zip extension." + (let ((end (or (string-contains tarball ".tar") + (string-contains tarball ".zip")))) + (substring tarball 0 end))) + (define (compressed-file? file) "Return true if FILE denotes a compressed file." (->bool (member (file-extension file) -- cgit v1.2.3 From 33f53947aa6d50ef7fe08c0ef9e32cdb9e77db89 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 4 Aug 2019 11:30:32 +0200 Subject: gnu-maintenance: KDE updater no longer relies on FTP access. Fetch the ls-lR.bz2 file list for download.kde.org, convert it into a list of file paths and cache the list. * guix/gnu-maintenance.scm (%kde-file-list-uri): New variable. (download.kde.org-files): New procedure. (latest-kde-release): Change to use DOWNLOAD.KDE.ORG-FILES and search for files in this list. --- guix/gnu-maintenance.scm | 100 +++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 92 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 8fce956c60..9ce06508a3 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov +;;; Copyright © 2019 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ #:use-module (sxml simple) #:use-module (ice-9 regex) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -613,15 +615,97 @@ releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) +(define %kde-file-list-uri + ;; URI of the file list (ls -lR format) for download.kde.org. + (string->uri "https://download.kde.org/ls-lR.bz2")) + +(define (download.kde.org-files) + ;;"Return the list of files available at download.kde.org." + + (define (ls-lR-line->filename path line) + ;; remove mode, blocks, user, group, size, date, time and one space + (regexp-substitute + #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) + + (define (canonicalize path) + (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) + (string-drop path (string-length "/srv/archives/ftp")) + path)) + (path (if (string-suffix? ":" path) + (string-drop-right path 1) + path)) + (path (if (not (string-suffix? "/" path)) + (string-append path "/") + path))) + path)) + + (define (write-cache input cache) + "Read bzipped ls-lR from INPUT, and write it as a list of file paths to +CACHE." + + (call-with-decompressed-port 'bzip2 input + (lambda (input) + (let loop_dirs ((files '())) + (let ((path (read-line input))) + (if + (or (eof-object? path) (string= path "")) + (write (reverse files) cache)) + (let loop_entries ((path (canonicalize path)) + (files files)) + (let ((line (read-line input))) + (cond + ((eof-object? line) + (write (reverse files) cache)) + ((string-prefix? "-" line) + (loop_entries path + (cons (ls-lR-line->filename path line) files))) + ((not (string= line "")) + (loop_entries path files)) + (#t (loop_dirs files)))))))))) + + (define (cache-miss uri) + (format (current-error-port) "fetching ~a...~%" (uri->string uri))) + + (let* ((port (http-fetch/cached %kde-file-list-uri + #:ttl 3600 + #:write-cache write-cache + #:cache-miss cache-miss)) + (files (read port))) + (close-port port) + files)) + (define (latest-kde-release package) - "Return the latest release of PACKAGE, the name of an KDE.org package." - (let ((uri (string->uri (origin-uri (package-source package))))) - (false-if-ftp-error - (latest-ftp-release - (package-upstream-name package) - #:server "ftp.mirrorservice.org" - #:directory (string-append "/sites/ftp.kde.org/pub/kde/" - (dirname (dirname (uri-path uri)))))))) + "Return the latest release of PACKAGE, a KDE package, or #f if it could not +be determined." + (let* ((uri (string->uri (origin-uri (package-source package)))) + (directory (dirname (dirname (uri-path uri)))) + (name (package-upstream-name package)) + (files (download.kde.org-files)) + (relevant (filter (lambda (file) + (and (string-prefix? directory file) + (release-file? name (basename file)))) + files))) + (match (sort relevant (lambda (file1 file2) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) + ((and tarballs (reference _ ...)) + (let* ((version (tarball->version reference)) + (tarballs (filter (lambda (file) + (string=? (tarball-sans-extension + (basename file)) + (tarball-sans-extension + (basename reference)))) + tarballs))) + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs))))) + (() + #f)))) (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." -- cgit v1.2.3 From d1dce0c3638a577a2ab713d2551f4aabe67d031c Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Tue, 3 Sep 2019 14:16:03 +0200 Subject: upstream: Move KDE updater into a separate module. As it was done for (guix import gnome). * guix/import/kde.scm: New file. * Makefile.am (MODULES): Add it. * guix/gnu-maintenance.scm (%kde-updater) (%kde-file-list-uri) (download.kde.org-files) (latest-kde-release): Remove. --- Makefile.am | 1 + guix/gnu-maintenance.scm | 102 ------------------------------ guix/import/kde.scm | 158 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 159 insertions(+), 102 deletions(-) create mode 100644 guix/import/kde.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 683b2242f0..7e3b5c1070 100644 --- a/Makefile.am +++ b/Makefile.am @@ -221,6 +221,7 @@ MODULES = \ guix/import/gnu.scm \ guix/import/hackage.scm \ guix/import/json.scm \ + guix/import/kde.scm \ guix/import/launchpad.scm \ guix/import/opam.scm \ guix/import/print.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 9ce06508a3..ef067704ad 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,7 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov -;;; Copyright © 2019 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +24,6 @@ #:use-module (sxml simple) #:use-module (ice-9 regex) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -64,7 +62,6 @@ %gnu-updater %gnu-ftp-updater - %kde-updater %xorg-updater %kernel.org-updater)) @@ -615,98 +612,6 @@ releases are on gnu.org." (define gnu-hosted? (url-prefix-predicate "mirror://gnu/")) -(define %kde-file-list-uri - ;; URI of the file list (ls -lR format) for download.kde.org. - (string->uri "https://download.kde.org/ls-lR.bz2")) - -(define (download.kde.org-files) - ;;"Return the list of files available at download.kde.org." - - (define (ls-lR-line->filename path line) - ;; remove mode, blocks, user, group, size, date, time and one space - (regexp-substitute - #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) - - (define (canonicalize path) - (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) - (string-drop path (string-length "/srv/archives/ftp")) - path)) - (path (if (string-suffix? ":" path) - (string-drop-right path 1) - path)) - (path (if (not (string-suffix? "/" path)) - (string-append path "/") - path))) - path)) - - (define (write-cache input cache) - "Read bzipped ls-lR from INPUT, and write it as a list of file paths to -CACHE." - - (call-with-decompressed-port 'bzip2 input - (lambda (input) - (let loop_dirs ((files '())) - (let ((path (read-line input))) - (if - (or (eof-object? path) (string= path "")) - (write (reverse files) cache)) - (let loop_entries ((path (canonicalize path)) - (files files)) - (let ((line (read-line input))) - (cond - ((eof-object? line) - (write (reverse files) cache)) - ((string-prefix? "-" line) - (loop_entries path - (cons (ls-lR-line->filename path line) files))) - ((not (string= line "")) - (loop_entries path files)) - (#t (loop_dirs files)))))))))) - - (define (cache-miss uri) - (format (current-error-port) "fetching ~a...~%" (uri->string uri))) - - (let* ((port (http-fetch/cached %kde-file-list-uri - #:ttl 3600 - #:write-cache write-cache - #:cache-miss cache-miss)) - (files (read port))) - (close-port port) - files)) - -(define (latest-kde-release package) - "Return the latest release of PACKAGE, a KDE package, or #f if it could not -be determined." - (let* ((uri (string->uri (origin-uri (package-source package)))) - (directory (dirname (dirname (uri-path uri)))) - (name (package-upstream-name package)) - (files (download.kde.org-files)) - (relevant (filter (lambda (file) - (and (string-prefix? directory file) - (release-file? name (basename file)))) - files))) - (match (sort relevant (lambda (file1 file2) - (version>? (tarball-sans-extension - (basename file1)) - (tarball-sans-extension - (basename file2))))) - ((and tarballs (reference _ ...)) - (let* ((version (tarball->version reference)) - (tarballs (filter (lambda (file) - (string=? (tarball-sans-extension - (basename file)) - (tarball-sans-extension - (basename reference)))) - tarballs))) - (upstream-source - (package name) - (version version) - (urls (map (lambda (file) - (string-append "mirror://kde/" file)) - tarballs))))) - (() - #f)))) - (define (latest-xorg-release package) "Return the latest release of PACKAGE, the name of an X.org package." (let ((uri (string->uri (origin-uri (package-source package))))) @@ -754,13 +659,6 @@ be determined." (pure-gnu-package? package)))) (latest latest-release*))) -(define %kde-updater - (upstream-updater - (name 'kde) - (description "Updater for KDE packages") - (pred (url-prefix-predicate "mirror://kde/")) - (latest latest-kde-release))) - (define %xorg-updater (upstream-updater (name 'xorg) diff --git a/guix/import/kde.scm b/guix/import/kde.scm new file mode 100644 index 0000000000..927ecc8263 --- /dev/null +++ b/guix/import/kde.scm @@ -0,0 +1,158 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2019 Hartmut Goebel +;;; +;;; 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 . + +(define-module (guix import kde) + #:use-module (guix http-client) + #:use-module (guix memoization) + #:use-module (guix gnu-maintenance) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-11) + #:use-module (web uri) + + #:export (%kde-updater)) + +;;; Commentary: +;;; +;;; This package provides not an actual importer but simply an updater for +;;; KDE packages. It grabs available files from the 'ls-lR.bz2' file +;;; available on download.kde.org. +;;; +;;; Code: + +(define (tarball->version tarball) + "Return the version TARBALL corresponds to. TARBALL is a file name like +\"coreutils-8.23.tar.xz\"." + (let-values (((name version) + (gnu-package-name->name+version + (tarball-sans-extension tarball)))) + version)) + +(define %kde-file-list-uri + ;; URI of the file list (ls -lR format) for download.kde.org. + (string->uri "https://download.kde.org/ls-lR.bz2")) + +(define (download.kde.org-files) + ;;"Return the list of files available at download.kde.org." + + (define (ls-lR-line->filename path line) + ;; Remove mode, blocks, user, group, size, date, time and one space, + ;; then prepend PATH + (regexp-substitute + #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post)) + + (define (canonicalize path) + (let* ((path (if (string-prefix? "/srv/archives/ftp/" path) + (string-drop path (string-length "/srv/archives/ftp")) + path)) + (path (if (string-suffix? ":" path) + (string-drop-right path 1) + path)) + (path (if (not (string-suffix? "/" path)) + (string-append path "/") + path))) + path)) + + (define (write-cache input cache) + "Read bzipped ls-lR from INPUT, and write it as a list of file paths to +CACHE." + (call-with-decompressed-port 'bzip2 input + (lambda (input) + (let loop_dirs ((files '())) + ;; process a new directory block + (let ((path (read-line input))) + (if + (or (eof-object? path) (string= path "")) + (write (reverse files) cache) + (let loop_entries ((path (canonicalize path)) + (files files)) + ;; process entries within the directory block + (let ((line (read-line input))) + (cond + ((eof-object? line) + (write (reverse files) cache)) + ((string-prefix? "-" line) + ;; this is a file entry: prepend to FILES, then re-enter + ;; the loop for remaining entries + (loop_entries path + (cons (ls-lR-line->filename path line) files) + )) + ((not (string= line "")) + ;; this is a non-file entry: ignore it, just re-enter the + ;; loop for remaining entries + (loop_entries path files)) + ;; empty line: directory block end, re-enter the outer + ;; loop for the next block + (#t (loop_dirs files))))))))))) + + (define (cache-miss uri) + (format (current-error-port) "fetching ~a...~%" (uri->string uri))) + + (let* ((port (http-fetch/cached %kde-file-list-uri + #:ttl 3600 + #:write-cache write-cache + #:cache-miss cache-miss)) + (files (read port))) + (close-port port) + files)) + +(define (latest-kde-release package) + "Return the latest release of PACKAGE, a KDE package, or #f if it could +not be determined." + (let* ((uri (string->uri (origin-uri (package-source package)))) + (directory (dirname (dirname (uri-path uri)))) + (name (package-upstream-name package)) + (files (download.kde.org-files)) + (relevant (filter (lambda (file) + (and (string-prefix? directory file) + (release-file? name (basename file)))) + files))) + (match (sort relevant (lambda (file1 file2) + (version>? (tarball-sans-extension + (basename file1)) + (tarball-sans-extension + (basename file2))))) + ((and tarballs (reference _ ...)) + (let* ((version (tarball->version reference)) + (tarballs (filter (lambda (file) + (string=? (tarball-sans-extension + (basename file)) + (tarball-sans-extension + (basename reference)))) + tarballs))) + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs))))) + (() + #f)))) + +(define %kde-updater + (upstream-updater + (name 'kde) + (description "Updater for KDE packages") + (pred (url-prefix-predicate "mirror://kde/")) + (latest latest-kde-release))) -- cgit v1.2.3 From 4eb69bf0d33810886ee118f38989cef696e4c868 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sun, 4 Aug 2019 11:32:39 +0200 Subject: import: KDE updater finds packages even in sub-directory. Fixes and finally fixes . Formerly packages living in a path like /stable/frameworks/5.60/portingAids/kross-5.60.0.tar.xz have not been found. * guix/import/kde.scm (uri->kde-path-pattern): New procedure. (latest-kde-release): Use pattern to search for file. --- guix/import/kde.scm | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/kde.scm b/guix/import/kde.scm index 927ecc8263..6873418d62 100644 --- a/guix/import/kde.scm +++ b/guix/import/kde.scm @@ -117,15 +117,47 @@ CACHE." (close-port port) files)) +(define (uri->kde-path-pattern uri) + "Build a regexp from the package's URI suitable for matching the package +path version-agnostic. + +Example: +Input: + mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip +Output: + //stable/frameworks/[^/]+/portingAids/ +" + + (define version-regexp + ;; regexp for matching versions as used in the ld-lR file + (make-regexp + (string-join '("^([0-9]+\\.)+[0-9]+-?" ;; 5.12.90, 4.2.0-preview + "^[0-9]+$" ;; 20031002 + ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1 + "|"))) + + (define (version->pattern part) + ;; If a path element might be a version, replace it by a catch-all part + (if (regexp-exec version-regexp part) + "[^/]+" + part)) + + (let* ((path (uri-path uri)) + (directory-parts (string-split (dirname path) #\/))) + (make-regexp + (string-append + (string-join (map version->pattern directory-parts) "/") + "/")))) + (define (latest-kde-release package) "Return the latest release of PACKAGE, a KDE package, or #f if it could not be determined." (let* ((uri (string->uri (origin-uri (package-source package)))) - (directory (dirname (dirname (uri-path uri)))) + (path-rx (uri->kde-path-pattern uri)) (name (package-upstream-name package)) (files (download.kde.org-files)) (relevant (filter (lambda (file) - (and (string-prefix? directory file) + (and (regexp-exec path-rx file) (release-file? name (basename file)))) files))) (match (sort relevant (lambda (file1 file2) -- cgit v1.2.3 From f58b2f38e4dfdbb8473fb2816d44fae6ad9cbc79 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Thu, 12 Sep 2019 20:20:26 +0300 Subject: build: cargo-build-system: Strip store hash from vendor-dir. * guix/build/cargo-build-system.scm (configure): When copying the sources into the vendor-dir strip off the hash before the package name. --- guix/build/cargo-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index f173b64c83..0134997c27 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -99,7 +99,7 @@ Cargo.toml file present at its root." (for-each (match-lambda ((name . path) - (let* ((basepath (basename path)) + (let* ((basepath (string-drop (basename path) 33)) (crate-dir (string-append vendor-dir "/" basepath))) (and (crate-src? path) ;; Gracefully handle duplicate inputs -- cgit v1.2.3 From 5ccec77176b7e0c67ed58c8849e5e76f3dd79a88 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Sep 2019 22:17:43 +0200 Subject: file-systems: Add /var/run/nscd to '%network-file-mappings'. This allows containers created by "guix environment -CN" or by "guix system container -N" to talk to the host nscd. * gnu/system/file-systems.scm (%network-file-mappings): Add "/var/run/nscd". * gnu/build/shepherd.scm (default-mounts)[nscd-socket]: Remove. * gnu/system/linux-container.scm (container-script)[nscd-run-directory] [nscd-mapping, nscd-os, nscd-specs]: Remove. [script]: Filter out from SPECS bind-mounts where the device does not exist. * guix/scripts/environment.scm (launch-environment/container) [optional-mapping->fs]: New procedure. [mappings]: Remove %NETWORK-FILE-MAPPINGS. [file-systems]: Add %NETWORK-FILE-MAPPINGS here, filtered through 'optional-mapping->fs'. --- gnu/build/shepherd.scm | 8 +------- gnu/system/file-systems.scm | 2 +- gnu/system/linux-container.scm | 35 ++++++++++++++--------------------- guix/scripts/environment.scm | 13 ++++++++----- 4 files changed, 24 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm index cf68f2108b..b32765ed5e 100644 --- a/gnu/build/shepherd.scm +++ b/gnu/build/shepherd.scm @@ -67,16 +67,10 @@ (file-system-mapping (source "/etc/group") (target source)))) - (define nscd-socket - (file-system-mapping - (source "/var/run/nscd") (target source) - (writable? #t))) - (append (cons (tmpfs "/tmp") %container-file-systems) (let ((mappings `(,@(if (memq 'net namespaces) '() - (cons nscd-socket - %network-file-mappings)) + %network-file-mappings) ,@(if (and (memq 'mnt namespaces) (not (memq 'user namespaces))) accounts diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index d11b36f25d..6cf6ccc53e 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -508,7 +508,7 @@ a bind mount." ;; symlink to a file in a tmpfs which, for an unknown reason, ;; cannot be bind mounted read-only within the container. (writable? (string=? file "/etc/resolv.conf")))) - %network-configuration-files)) + (cons "/var/run/nscd" %network-configuration-files))) (define (file-system-type-predicate type) "Return a predicate that, when passed a file system, returns #t if that file diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 6273cee3d3..451a72762c 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -147,13 +147,6 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." "Return a derivation of a script that runs OS as a Linux container. MAPPINGS is a list of objects that specify the files/directories that will be shared with the host system." - (define nscd-run-directory "/var/run/nscd") - - (define nscd-mapping - (file-system-mapping - (source nscd-run-directory) - (target nscd-run-directory))) - (define (mountable-file-system? file-system) ;; Return #t if FILE-SYSTEM should be mounted in the container. (and (not (string=? "/" (file-system-mount-point file-system))) @@ -168,12 +161,7 @@ that will be shared with the host system." os (cons %store-mapping mappings) #:shared-network? shared-network? #:extra-file-systems %container-file-systems)) - (nscd-os (containerized-operating-system - os (cons* nscd-mapping %store-mapping mappings) - #:shared-network? shared-network? - #:extra-file-systems %container-file-systems)) - (specs (os-file-system-specs os)) - (nscd-specs (os-file-system-specs nscd-os))) + (specs (os-file-system-specs os))) (define script (with-imported-modules (source-module-closure @@ -182,14 +170,19 @@ that will be shared with the host system." #~(begin (use-modules (gnu build linux-container) (gnu system file-systems) ;spec->file-system - (guix build utils)) - - (call-with-container - (map spec->file-system - (if (and #$shared-network? - (file-exists? #$nscd-run-directory)) - '#$nscd-specs - '#$specs)) + (guix build utils) + (srfi srfi-1)) + + (define file-systems + (filter-map (lambda (spec) + (let* ((fs (spec->file-system spec)) + (flags (file-system-flags fs))) + (and (or (not (memq 'bind-mount flags)) + (file-exists? (file-system-device fs))) + fs))) + '#$specs)) + + (call-with-container file-systems (lambda () (setenv "HOME" "/root") (setenv "TMPDIR" "/tmp") diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index cf58768300..535f181bfd 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -462,6 +462,10 @@ host file systems to mount inside the container. If USER is not #f, each target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the environment profile." + (define (optional-mapping->fs mapping) + (and (file-exists? (file-system-mapping-source mapping)) + (file-system-mapping->bind-mount mapping))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -498,11 +502,6 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (target cwd) (writable? #t))) '()))) - ;; When in Rome, do as Nix build.cc does: Automagically - ;; map common network configuration files. - (if network? - %network-file-mappings - '()) ;; Mappings for the union closure of all inputs. (map (lambda (dir) (file-system-mapping @@ -511,6 +510,10 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from (writable? #f))) reqs))) (file-systems (append %container-file-systems + (if network? + (filter-map optional-mapping->fs + %network-file-mappings) + '()) (map file-system-mapping->bind-mount mappings)))) (exit/status -- cgit v1.2.3 From 43ffa11fdc4de4197a1096f6ebc4067115f9eb26 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Fri, 13 Sep 2019 15:05:10 +0300 Subject: build-system/cargo: Use 'strip-store-file-name'. This is a follow-up to f58b2f38e4dfdbb8473fb2816d44fae6ad9cbc79. * guix/build/cargo-build-system.scm (configure): Use bespoke 'strip-store-file-name' function. --- guix/build/cargo-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 0134997c27..c69cae5afd 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -99,7 +99,7 @@ Cargo.toml file present at its root." (for-each (match-lambda ((name . path) - (let* ((basepath (string-drop (basename path) 33)) + (let* ((basepath (strip-store-file-name path)) (crate-dir (string-append vendor-dir "/" basepath))) (and (crate-src? path) ;; Gracefully handle duplicate inputs -- cgit v1.2.3 From 3af85f832dd007296ec64ddc34beadd397481311 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Fri, 13 Sep 2019 15:09:34 +0300 Subject: build-system/cargo: Remove unused function. * guix/build/cargo-build-system.scm (touch): Remove it. --- guix/build/cargo-build-system.scm | 3 --- 1 file changed, 3 deletions(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index c69cae5afd..4be5443083 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -168,9 +168,6 @@ directory = '" port) (apply invoke `("cargo" "test" ,@cargo-test-flags)) #t)) -(define (touch file-name) - (call-with-output-file file-name (const #t))) - (define* (install #:key inputs outputs skip-build? #:allow-other-keys) "Install a given Cargo package." (let* ((out (assoc-ref outputs "out"))) -- cgit v1.2.3 From 6e377b88930226f3f74ba9fac74d80c36494d9be Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 14 Sep 2019 00:36:51 +0200 Subject: import/utils: beautify-description: Recognize more fragments. * guix/import/utils.scm (beautify-description): Handle additional common initial sentence fragments in descriptions. --- guix/import/utils.scm | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 252875eeab..4694b6e7ef 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -212,10 +212,19 @@ with dashes." (define (beautify-description description) "Improve the package DESCRIPTION by turning a beginning sentence fragment into a proper sentence and by using two spaces between sentences." - (let ((cleaned (if (string-prefix? "A " description) - (string-append "This package provides a" - (substring description 1)) - description))) + (let ((cleaned (cond + ((string-prefix? "A " description) + (string-append "This package provides a" + (substring description 1))) + ((string-prefix? "Provides " description) + (string-append "This package provides" + (substring description + (string-length "Provides")))) + ((string-prefix? "Functions " description) + (string-append "This package provides functions" + (substring description + (string-length "Functions")))) + (else description)))) ;; Use double spacing between sentences (regexp-substitute/global #f "\\. \\b" cleaned 'pre ". " 'post))) -- cgit v1.2.3 From 9bbaf2ae72ce8457702f50277fee908d2c43d13c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Sep 2019 17:35:08 +0200 Subject: pack: Add packages in the order in which they appear on the command line. * guix/scripts/pack.scm (guix-pack)[manifest-from-args](packages): Reverse order of packages taken from OPTS. --- guix/scripts/pack.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index dd91a24284..055d6c95f5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -944,7 +944,8 @@ Create a bundle of PACKAGE.\n")) (list (transform store package) output)) ((? package? package) (list (transform store package) "out"))) - (filter-map maybe-package-argument opts))) + (reverse + (filter-map maybe-package-argument opts)))) (manifest-file (assoc-ref opts 'manifest))) (define properties (if (assoc-ref opts 'save-provenance?) -- cgit v1.2.3 From 0074844366381e3056d09492b8b437836c7adb61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Sep 2019 17:32:16 +0200 Subject: pack: Provide a meaningful "repository name" for Docker. Previously, images produced by 'guix pack -f docker' would always show up as "profile" in the output of 'docker images'. With this change, 'docker images' shows a name constructed from the packages found in the image--e.g., "bash-coreutils-grep-sed". * guix/docker.scm (canonicalize-repository-name): New procedure. (generate-tag): Remove. (manifest): Add optional 'tag' parameter and honor it. (repositories): Likewise. (build-docker-image): Add #:repository parameter and pass it to 'manifest' and 'repositories'. * guix/scripts/pack.scm (docker-image)[build]: Compute 'tag' and pass it as #:repository to 'build-docker-image'. --- guix/docker.scm | 43 ++++++++++++++++++++++++++++++------------- guix/scripts/pack.scm | 13 +++++++++++++ 2 files changed, 43 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index 757bdeb458..97ac6d982b 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -57,22 +57,36 @@ (created . ,time) (container_config . #nil))) -(define (generate-tag path) - "Generate an image tag for the given PATH." - (match (string-split (basename path) #\-) - ((hash name . rest) (string-append name ":" hash)))) +(define (canonicalize-repository-name name) + "\"Repository\" names are restricted to roughtl [a-z0-9_.-]. +Return a version of TAG that follows these rules." + (define ascii-letters + (string->char-set "abcdefghijklmnopqrstuvwxyz")) -(define (manifest path id) + (define separators + (string->char-set "_-.")) + + (define repo-char-set + (char-set-union char-set:digit ascii-letters separators)) + + (string-map (lambda (chr) + (if (char-set-contains? repo-char-set chr) + chr + #\.)) + (string-trim (string-downcase name) separators))) + +(define* (manifest path id #:optional (tag "guix")) "Generate a simple image manifest." - `#(((Config . "config.json") - (RepoTags . #(,(generate-tag path))) - (Layers . #(,(string-append id "/layer.tar")))))) + (let ((tag (canonicalize-repository-name tag))) + `#(((Config . "config.json") + (RepoTags . #(,(string-append tag ":latest"))) + (Layers . #(,(string-append id "/layer.tar"))))))) ;; According to the specifications this is required for backwards ;; compatibility. It duplicates information provided by the manifest. -(define (repositories path id) +(define* (repositories path id #:optional (tag "guix")) "Generate a repositories file referencing PATH and the image ID." - `((,(generate-tag path) . ((latest . ,id))))) + `((,(canonicalize-repository-name tag) . ((latest . ,id))))) ;; See https://github.com/opencontainers/image-spec/blob/master/config.md (define* (config layer time arch #:key entry-point (environment '())) @@ -112,6 +126,7 @@ (define* (build-docker-image image paths prefix #:key + (repository "guix") (extra-files '()) (transformations '()) (system (utsname:machine (uname))) @@ -121,7 +136,9 @@ compressor (creation-time (current-time time-utc))) "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX -must be a store path that is a prefix of any store paths in PATHS. +must be a store path that is a prefix of any store paths in PATHS. REPOSITORY +is a descriptive name that will show up in \"REPOSITORY\" column of the output +of \"docker images\". When DATABASE is true, copy it to /var/guix/db in the image and create /var/guix/gcroots and friends. @@ -243,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata." #:entry-point entry-point)))) (with-output-to-file "manifest.json" (lambda () - (scm->json (manifest prefix id)))) + (scm->json (manifest prefix id repository)))) (with-output-to-file "repositories" (lambda () - (scm->json (repositories prefix id))))) + (scm->json (repositories prefix id repository))))) (apply invoke "tar" "-cf" image "-C" directory `(,@%tar-determinism-options diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 055d6c95f5..2543f0c0b5 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -516,6 +516,18 @@ the image." `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) + (define tag + ;; Compute a meaningful "repository" name, which will show up in + ;; the output of "docker images". + (let ((manifest (profile-manifest #$profile))) + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names))))))) ;drop one entry (setenv "PATH" (string-append #$archiver "/bin")) @@ -524,6 +536,7 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile + #:repository tag #:database #+database #:system (or #$target (utsname:machine (uname))) #:environment environment -- cgit v1.2.3 From 76c0b608219cc1f58decbd85f4a8194337f0558d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 16 Sep 2019 11:16:40 +0200 Subject: import/cran: Export %bioconductor-version. * guix/import/cran.scm (%bioconductor-version): Export it. --- guix/import/cran.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 35caa3e463..e47aff2b12 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -49,6 +49,7 @@ cran-recursive-import %cran-updater %bioconductor-updater + %bioconductor-version cran-package? bioconductor-package? -- cgit v1.2.3 From 41ca406fa54e69f61c55b11ffe5cf465192a907c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 16 Sep 2019 11:23:57 +0200 Subject: build-system/r: Use %bioconductor-version. * guix/build-system/r.scm (bioconductor-uri): Use %bioconductor-version instead of hard-coding the version string. --- guix/build-system/r.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index dd2a9fe8de..936ad974d0 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) + #:use-module ((guix import cran) #:select (%bioconductor-version)) #:use-module (ice-9 match) #:use-module (srfi srfi-26) #:export (%r-build-system-modules @@ -58,8 +59,8 @@ release corresponding to NAME and VERSION." type-url-part "/src/contrib/" name "_" version ".tar.gz") - ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.9" + (string-append "https://bioconductor.org/packages/" + %bioconductor-version type-url-part "/src/contrib/Archive/" name "_" version ".tar.gz")))) -- cgit v1.2.3 From 74e7465c9b3758c1509a3e0dbe575e2014e20f0a Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 16 Sep 2019 14:34:15 +0300 Subject: Revert "build-system/r: Use %bioconductor-version." This reverts commit 41ca406fa54e69f61c55b11ffe5cf465192a907c. This commit breaks 'guix pull', as reported by Hao Chen. --- guix/build-system/r.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 936ad974d0..dd2a9fe8de 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019 Ricardo Wurmus +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,7 +24,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module ((guix import cran) #:select (%bioconductor-version)) #:use-module (ice-9 match) #:use-module (srfi srfi-26) #:export (%r-build-system-modules @@ -59,8 +58,8 @@ release corresponding to NAME and VERSION." type-url-part "/src/contrib/" name "_" version ".tar.gz") - (string-append "https://bioconductor.org/packages/" - %bioconductor-version + ;; TODO: use %bioconductor-version from (guix import cran) + (string-append "https://bioconductor.org/packages/3.9" type-url-part "/src/contrib/Archive/" name "_" version ".tar.gz")))) -- cgit v1.2.3