aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/cargo-build-system.scm5
-rw-r--r--guix/docker.scm43
-rw-r--r--guix/gnu-maintenance.scm44
-rw-r--r--guix/import/cran.scm1
-rw-r--r--guix/import/crate.scm29
-rw-r--r--guix/import/github.scm2
-rw-r--r--guix/import/kde.scm190
-rw-r--r--guix/import/utils.scm17
-rw-r--r--guix/packages.scm2
-rw-r--r--guix/scripts/environment.scm13
-rw-r--r--guix/scripts/gc.scm15
-rw-r--r--guix/scripts/import/crate.scm13
-rw-r--r--guix/scripts/pack.scm16
-rw-r--r--guix/scripts/refresh.scm12
-rw-r--r--guix/store/roots.scm129
-rw-r--r--guix/upstream.scm12
-rw-r--r--guix/utils.scm7
17 files changed, 466 insertions, 84 deletions
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index f173b64c83..4be5443083 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 (strip-store-file-name path))
(crate-dir (string-append vendor-dir "/" basepath)))
(and (crate-src? path)
;; Gracefully handle duplicate inputs
@@ -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")))
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/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index d63d44f629..ef067704ad 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -62,7 +62,6 @@
%gnu-updater
%gnu-ftp-updater
- %kde-updater
%xorg-updater
%kernel.org-updater))
@@ -230,12 +229,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 +254,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 +486,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 +560,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
@@ -615,16 +612,6 @@ releases are on gnu.org."
(define gnu-hosted?
(url-prefix-predicate "mirror://gnu/"))
-(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))))))))
-
(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)))))
@@ -672,13 +659,6 @@ releases are on gnu.org."
(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/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?
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 <david@craven.ch>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;;
;;; 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<?)))
(make-crate-sexp #:name crate-name
- #:version (crate-version-number version)
+ #:version (crate-version-number version*)
#:cargo-inputs cargo-inputs
#:cargo-development-inputs cargo-development-inputs
#:home-page (or (crate-home-page crate)
(crate-repository crate))
#:synopsis (crate-description crate)
#:description (crate-description crate)
- #:license (and=> (crate-version-license version)
+ #:license (and=> (crate-version-license version*)
string->license)))))
(define (guix-package->crate-name package)
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))
diff --git a/guix/import/kde.scm b/guix/import/kde.scm
new file mode 100644
index 0000000000..6873418d62
--- /dev/null
+++ b/guix/import/kde.scm
@@ -0,0 +1,190 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 (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))))
+ (path-rx (uri->kde-path-pattern uri))
+ (name (package-upstream-name package))
+ (files (download.kde.org-files))
+ (relevant (filter (lambda (file)
+ (and (regexp-exec path-rx 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)))
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)))
diff --git a/guix/packages.scm b/guix/packages.scm
index 39ab28d807..f2c94c7bc2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -352,7 +352,7 @@ object."
(match (package-location package)
(($ <location> 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))
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index f7f7edda48..cfe0a37c42 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -463,6 +463,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
@@ -499,11 +503,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
@@ -512,6 +511,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
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
@@ -57,6 +57,8 @@ Invoke the garbage collector.\n"))
(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_ "
--list-dead list dead paths"))
@@ -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/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 <davet@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;;
;;; 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~%")))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index de5b3fc0ff..920d6c01fe 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
@@ -944,7 +957,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?)
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/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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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))))
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
- (($ <upstream-updater> name description pred latest)
- (and (pred package) latest)))
- updaters))
+ (find (match-lambda
+ (($ <upstream-updater> name description pred latest)
+ (pred package)))
+ updaters))
(define (package-latest-release package updaters)
"Return an upstream source to update PACKAGE, a <package> 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)
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)