summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/linux-module.scm4
-rw-r--r--guix/build-system/renpy.scm1
-rw-r--r--guix/build/download.scm22
-rw-r--r--guix/build/emacs-utils.scm2
-rw-r--r--guix/build/haskell-build-system.scm46
-rw-r--r--guix/build/linux-module-build-system.scm35
-rw-r--r--guix/build/renpy-build-system.scm2
-rw-r--r--guix/build/syscalls.scm29
-rw-r--r--guix/channels.scm9
-rw-r--r--guix/cpio.scm21
-rw-r--r--guix/discovery.scm32
-rw-r--r--guix/extracting-download.scm179
-rw-r--r--guix/git.scm92
-rw-r--r--guix/graph.scm45
-rw-r--r--guix/import/crate.scm8
-rw-r--r--guix/import/git.scm225
-rw-r--r--guix/import/go.scm13
-rw-r--r--guix/import/hackage.scm11
-rw-r--r--guix/import/minetest.scm73
-rw-r--r--guix/import/pypi.scm20
-rw-r--r--guix/import/stackage.scm111
-rw-r--r--guix/packages.scm23
-rw-r--r--guix/scripts/graph.scm11
-rw-r--r--guix/scripts/home.scm524
-rw-r--r--guix/scripts/home/import.scm243
-rw-r--r--guix/scripts/publish.scm82
-rw-r--r--guix/scripts/system.scm7
-rw-r--r--guix/self.scm13
-rw-r--r--guix/swh.scm52
-rw-r--r--guix/tests/git.scm7
30 files changed, 1750 insertions, 192 deletions
diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm
index 7bafee5a7a..0eab919deb 100644
--- a/guix/build-system/linux-module.scm
+++ b/guix/build-system/linux-module.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -158,6 +159,7 @@
(phases '%standard-phases)
(outputs '("out"))
(make-flags ''())
+ (parallel-build? #t)
(system (%current-system))
(source-directory ".")
(guile #f)
@@ -184,6 +186,7 @@
#:tests? #$tests?
#:outputs #$(outputs->gexp outputs)
#:make-flags #$make-flags
+ #:parallel-build? #$parallel-build?
#:inputs #$(input-tuples->gexp inputs)))))
(mlet %store-monad ((guile (package->derivation (or guile (default-guile))
@@ -201,6 +204,7 @@
(guile #f)
(outputs '("out"))
(make-flags ''())
+ (parallel-build? #t)
(search-paths '())
(native-search-paths '())
(tests? #f)
diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm
index 0ee73ec969..f1070951ee 100644
--- a/guix/build-system/renpy.scm
+++ b/guix/build-system/renpy.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
diff --git a/guix/build/download.scm b/guix/build/download.scm
index c8ddadfdd4..fd8fe69901 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -674,10 +674,23 @@ and write the output to FILE."
(match (fetch-specification uris)
(#f (format #t "could not find its Disarchive specification~%")
#f)
- (spec (parameterize ((%disarchive-log-port (current-output-port)))
+ (spec (parameterize ((%disarchive-log-port (current-output-port))
+ (%verify-swh-certificate? verify-certificate?))
(false-if-exception*
(disarchive-assemble spec file #:resolver resolve))))))))
+(define (internet-archive-uri uri)
+ "Return a URI corresponding to an Internet Archive backup of URI, or #f if
+URI does not denote a Web URI."
+ (and (memq (uri-scheme uri) '(http https))
+ (let* ((now (time-utc->date (current-time time-utc)))
+ (date (date->string now "~Y~m~d~H~M~S")))
+ ;; Note: the date in the URL can be anything and web.archive.org
+ ;; automatically redirects to the closest date.
+ (build-uri 'https #:host "web.archive.org"
+ #:path (string-append "/web/" date "/"
+ (uri->string uri))))))
+
(define* (url-fetch url file
#:key
(timeout 10) (verify-certificate? #t)
@@ -769,7 +782,12 @@ otherwise simply ignore them."
(setvbuf (current-error-port) 'line)
- (let try ((uri (append uri content-addressed-uris)))
+ (let try ((uri (append uri content-addressed-uris
+ (match uri
+ ((first . _)
+ (or (and=> (internet-archive-uri first) list)
+ '()))
+ (() '())))))
(match uri
((uri tail ...)
(or (fetch uri file)
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm
index 5f7ba71244..64ef40e25a 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;; Copyright © 2019 Leo Prikler <leo.prikler@student.tugraz.at>
+;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 28253ce2f0..ef6cb316ee 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
+;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -63,13 +64,14 @@
((file-exists? "Setup.lhs")
"Setup.lhs")
(else
- #f))))
+ #f)))
+ (pkgdb (string-append "-package-db=" %tmp-db-dir)))
(if setup-file
(begin
(format #t "running \"runhaskell Setup.hs\" with command ~s \
and parameters ~s~%"
command params)
- (apply invoke "runhaskell" setup-file command params))
+ (apply invoke "runhaskell" pkgdb setup-file command params))
(error "no Setup.hs nor Setup.lhs found"))))
(define* (configure #:key outputs inputs tests? (configure-flags '())
@@ -141,17 +143,6 @@ and parameters ~s~%"
(find-files lib "\\.a$"))))
#t)
-(define (grep rx port)
- "Given a regular-expression RX including a group, read from PORT until the
-first match and return the content of the group."
- (let ((line (read-line port)))
- (if (eof-object? line)
- #f
- (let ((rx-result (regexp-exec rx line)))
- (if rx-result
- (match:substring rx-result 1)
- (grep rx port))))))
-
(define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
"Setup the compiler environment."
(let* ((haskell (assoc-ref inputs "haskell"))
@@ -173,15 +164,8 @@ first match and return the content of the group."
"Generate the GHC package database."
(let* ((haskell (assoc-ref inputs "haskell"))
(name-version (strip-store-file-name haskell))
- (input-dirs (match inputs
- (((_ . dir) ...)
- dir)
- (_ '())))
;; Silence 'find-files' (see 'evaluate-search-paths')
- (conf-dirs (with-null-error-port
- (search-path-as-list
- `(,(string-append "lib/" name-version))
- input-dirs #:pattern ".*\\.conf.d$")))
+ (conf-dirs (search-path-as-string->list (getenv "GHC_PACKAGE_PATH")))
(conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
(mkdir-p %tmp-db-dir)
(for-each (lambda (file)
@@ -233,6 +217,8 @@ given Haskell package."
(if (not (vhash-assoc id seen))
(let ((dep-conf (string-append src "/" id ".conf"))
(dep-conf* (string-append dest "/" id ".conf")))
+ (when (not (file-exists? dep-conf))
+ (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file)))
(copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead?
(loop (vhash-cons id #t seen)
(append lst (conf-depends dep-conf))))
@@ -241,12 +227,13 @@ given Haskell package."
(let* ((out (assoc-ref outputs "out"))
(doc (assoc-ref outputs "doc"))
(haskell (assoc-ref inputs "haskell"))
- (name-verion (strip-store-file-name haskell))
+ (name-version (strip-store-file-name haskell))
+ (version (last (string-split name-version #\-)))
(lib (string-append (or (assoc-ref outputs "lib") out) "/lib"))
(config-dir (string-append lib
- "/" name-verion
+ "/ghc-" version
"/" name ".conf.d"))
- (id-rx (make-regexp "^id: *(.*)$"))
+ (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline))
(config-file (string-append out "/" name ".conf"))
(params
(list (string-append "--gen-pkg-config=" config-file))))
@@ -254,8 +241,15 @@ given Haskell package."
;; The conf file is created only when there is a library to register.
(when (file-exists? config-file)
(mkdir-p config-dir)
- (let ((config-file-name+id
- (call-with-ascii-input-file config-file (cut grep id-rx <>))))
+ (let* ((contents (call-with-input-file config-file read-string))
+ (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1)))
+
+ (when (or
+ (and
+ (string? config-file-name+id)
+ (string-null? config-file-name+id))
+ (not config-file-name+id))
+ (error (format #f "The package id for ~a is empty. This is a bug." config-file)))
;; Remove reference to "doc" output from "lib" (or "out") by rewriting the
;; "haddock-interfaces" field and removing the optional "haddock-html"
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index 729ab6154f..18ccf7cd8b 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -33,7 +34,7 @@
;;
;; Code:
-;; Copied from make-linux-libre's "configure" phase.
+;; Similar to make-linux-libre's "configure" phase.
(define* (configure #:key inputs target arch #:allow-other-keys)
(setenv "KCONFIG_NOTIMESTAMP" "1")
(setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))
@@ -42,23 +43,28 @@
(format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))
(when target
+ ;; TODO? (setenv "EXTRA_VERSION" ,extra-version)
+ ;; TODO? kernel ".config".
(setenv "CROSS_COMPILE" (string-append target "-"))
(format #t "`CROSS_COMPILE' set to `~a'~%"
- (getenv "CROSS_COMPILE")))
- ; TODO: (setenv "EXTRA_VERSION" ,extra-version)
- ; TODO: kernel ".config".
- #t)
+ (getenv "CROSS_COMPILE"))))
-(define* (build #:key inputs make-flags (source-directory ".") #:allow-other-keys)
+(define* (build #:key (make-flags '()) (parallel-build? #t)
+ (source-directory ".")
+ inputs
+ #:allow-other-keys)
(apply invoke "make" "-C"
(string-append (assoc-ref inputs "linux-module-builder")
"/lib/modules/build")
- (string-append "M=" (getcwd) "/" source-directory)
- (or make-flags '())))
+ (string-append "M=" (canonicalize-path source-directory))
+ `(,@(if parallel-build?
+ `("-j" ,(number->string (parallel-job-count)))
+ '())
+ ,@make-flags)))
-;; This block was copied from make-linux-libre--only took the "modules_install"
-;; part.
-(define* (install #:key make-flags (source-directory ".")
+;; Similar to the "modules_install" part of make-linux-libre.
+(define* (install #:key (make-flags '()) (parallel-build? #t)
+ (source-directory ".")
inputs native-inputs outputs
#:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
@@ -68,7 +74,7 @@
(apply invoke "make" "-C"
(string-append (assoc-ref inputs "linux-module-builder")
"/lib/modules/build")
- (string-append "M=" (getcwd) "/" source-directory)
+ (string-append "M=" (canonicalize-path source-directory))
;; Disable depmod because the Guix system's module directory
;; is an union of potentially multiple packages. It is not
;; possible to use depmod to usefully calculate a dependency
@@ -79,7 +85,10 @@
(string-append "INSTALL_MOD_PATH=" out)
"INSTALL_MOD_STRIP=1"
"modules_install"
- (or make-flags '()))))
+ `(,@(if parallel-build?
+ `("-j" ,(number->string (parallel-job-count)))
+ '())
+ ,@make-flags))))
(define %standard-phases
(modify-phases gnu:%standard-phases
diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm
index 66683971c5..e4a88456be 100644
--- a/guix/build/renpy-build-system.scm
+++ b/guix/build/renpy-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at>
+;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index ac1b0c2eea..99a3b45004 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -7,6 +7,7 @@
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -56,6 +57,9 @@
restart-on-EINTR
+ device-number
+ device-number->major+minor
+
mount?
mount-device-number
mount-source
@@ -450,6 +454,29 @@ the returned procedure is called."
;;;
+;;; Block devices.
+;;;
+
+;; Convert between major:minor pairs and packed ‘device number’ representation.
+;; XXX These aren't syscalls, but if you squint very hard they are part of the
+;; FFI or however you want to justify me not finding a better fit… :-)
+(define (device-number major minor) ; see glibc's <sys/sysmacros.h>
+ "Return the device number for the device with MAJOR and MINOR, for use as
+the last argument of `mknod'."
+ (logior (ash (logand #x00000fff major) 8)
+ (ash (logand #xfffff000 major) 32)
+ (logand #x000000ff minor)
+ (ash (logand #xffffff00 minor) 12)))
+
+(define (device-number->major+minor device) ; see glibc's <sys/sysmacros.h>
+ "Return two values: the major and minor device numbers that make up DEVICE."
+ (values (logior (ash (logand #x00000000000fff00 device) -8)
+ (ash (logand #xfffff00000000000 device) -32))
+ (logior (logand #x00000000000000ff device)
+ (ash (logand #x00000ffffff00000 device) -12))))
+
+
+;;;
;;; File systems.
;;;
@@ -628,7 +655,7 @@ current process."
(define (string->device-number str)
(match (string-split str #\:)
(((= string->number major) (= string->number minor))
- (+ (* major 256) minor))))
+ (device-number major minor))))
(call-with-input-file "/proc/self/mountinfo"
(lambda (port)
diff --git a/guix/channels.scm b/guix/channels.scm
index 476d62e1f4..e4e0428eb5 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -1089,8 +1089,13 @@ cannot be found."
(if (channel-news-entry-commit entry)
entry
(let* ((tag (channel-news-entry-tag entry))
- (reference (string-append "refs/tags/" tag))
- (oid (reference-name->oid repository reference)))
+ (reference (reference-lookup repository
+ (string-append "refs/tags/" tag)))
+ (target (reference-target reference))
+ (oid (let ((obj (object-lookup repository target)))
+ (if (= OBJ-TAG (object-type obj)) ;annotated tag?
+ (tag-target-id (tag-lookup repository target))
+ target))))
(channel-news-entry (oid->string oid) tag
(channel-news-entry-title entry)
(channel-news-entry-body entry)))))
diff --git a/guix/cpio.scm b/guix/cpio.scm
index 8038a11f3c..d4a7d5f1e0 100644
--- a/guix/cpio.scm
+++ b/guix/cpio.scm
@@ -18,6 +18,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix cpio)
+ #:use-module ((guix build syscalls) #:select (device-number
+ device-number->major+minor))
#:use-module ((guix build utils) #:select (dump-port))
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
@@ -129,8 +131,8 @@
(nlink 1) (mtime 0) (size 0)
(dev 0) (rdev 0) (name-size 0))
"Return a new cpio file header."
- (let-values (((major minor) (device->major+minor dev))
- ((rmajor rminor) (device->major+minor rdev)))
+ (let-values (((major minor) (device-number->major+minor dev))
+ ((rmajor rminor) (device-number->major+minor rdev)))
(%make-cpio-header MAGIC
inode mode uid gid
nlink mtime
@@ -154,21 +156,6 @@ denotes, similar to 'stat:type'."
(else
(error "unsupported file type" mode)))))
-(define (device-number major minor) ; see glibc's <sys/sysmacros.h>
- "Return the device number for the device with MAJOR and MINOR, for use as
-the last argument of `mknod'."
- (logior (ash (logand #x00000fff major) 8)
- (ash (logand #xfffff000 major) 32)
- (logand #x000000ff minor)
- (ash (logand #xffffff00 minor) 12)))
-
-(define (device->major+minor device) ; see glibc's <sys/sysmacros.h>
- "Return two values: the major and minor device numbers that make up DEVICE."
- (values (logior (ash (logand #x00000000000fff00 device) -8)
- (ash (logand #xfffff00000000000 device) -32))
- (logior (logand #x00000000000000ff device)
- (ash (logand #x00000ffffff00000 device) -12))))
-
(define* (file->cpio-header file #:optional (file-name file)
#:key (stat lstat))
"Return a cpio header corresponding to the info returned by STAT for FILE,
diff --git a/guix/discovery.scm b/guix/discovery.scm
index b84b9ff370..81d4ca600f 100644
--- a/guix/discovery.scm
+++ b/guix/discovery.scm
@@ -107,19 +107,25 @@ name and the exception key and arguments."
(define prefix-len
(string-length directory))
- (filter-map (lambda (file)
- (let* ((relative (string-drop file prefix-len))
- (module (file-name->module-name relative)))
- (catch #t
- (lambda ()
- (resolve-interface module))
- (lambda args
- ;; Report the error, but keep going.
- (warn file module args)
- #f))))
- (scheme-files (if sub-directory
- (string-append directory "/" sub-directory)
- directory))))
+ ;; Hide Guile warnings such as "source file [...] newer than compiled" when
+ ;; loading user code, unless we're hacking on Guix proper. See
+ ;; <https://issues.guix.gnu.org/43747>.
+ (parameterize ((current-warning-port (if (getenv "GUIX_UNINSTALLED")
+ (current-warning-port)
+ (%make-void-port "w"))))
+ (filter-map (lambda (file)
+ (let* ((relative (string-drop file prefix-len))
+ (module (file-name->module-name relative)))
+ (catch #t
+ (lambda ()
+ (resolve-interface module))
+ (lambda args
+ ;; Report the error, but keep going.
+ (warn file module args)
+ #f))))
+ (scheme-files (if sub-directory
+ (string-append directory "/" sub-directory)
+ directory)))))
(define* (scheme-modules* directory #:optional sub-directory)
"Return the list of module names found under SUB-DIRECTORY in DIRECTORY.
diff --git a/guix/extracting-download.scm b/guix/extracting-download.scm
new file mode 100644
index 0000000000..4b7dcc7e83
--- /dev/null
+++ b/guix/extracting-download.scm
@@ -0,0 +1,179 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2020 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 extracting-download)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module ((guix build download) #:prefix build:)
+ #:use-module ((guix build utils) #:hide (delete))
+ #:use-module (guix gexp)
+ #:use-module (guix modules)
+ #:use-module (guix monads)
+ #:use-module (guix packages) ;; for %current-system
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (srfi srfi-26)
+ #:export (http-fetch/extract
+ download-to-store/extract))
+
+;;;
+;;; Produce fixed-output derivations with data extracted from n archive
+;;; fetched over HTTP or FTP.
+;;;
+;;; This is meant to be used for package repositories where the actual source
+;;; archive is packed into another archive, eventually carrying meta-data.
+;;; Using this derivation saves both storing the outer archive and extracting
+;;; the actual one at build time. The hash is calculated on the actual
+;;; archive to ease validating the stored file.
+;;;
+
+(define* (http-fetch/extract url filename-to-extract hash-algo hash
+ #:optional name
+ #:key (system (%current-system)) (guile (default-guile)))
+ "Return a fixed-output derivation that fetches an archive at URL, and
+extracts FILE_TO_EXTRACT from the archive. The FILE_TO_EXTRACT is expected to
+have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the
+base name of URL; optionally, NAME can specify a different file name."
+ (define file-name
+ (match url
+ ((head _ ...)
+ (basename head))
+ (_
+ (basename url))))
+
+ (define guile-zlib
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
+
+ (define guile-json
+ (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
+
+ (define gnutls
+ (module-ref (resolve-interface '(gnu packages tls)) 'gnutls))
+
+ (define inputs
+ `(("tar" ,(module-ref (resolve-interface '(gnu packages base))
+ 'tar))))
+
+ (define config.scm
+ (scheme-file "config.scm"
+ #~(begin
+ (define-module (guix config)
+ #:export (%system))
+
+ (define %system
+ #$(%current-system)))))
+
+ (define modules
+ (cons `((guix config) => ,config.scm)
+ (delete '(guix config)
+ (source-module-closure '((guix build download)
+ (guix build utils)
+ (guix utils)
+ (web uri))))))
+
+ (define build
+ (with-imported-modules modules
+ (with-extensions (list guile-json gnutls ;for (guix swh)
+ guile-zlib)
+ #~(begin
+ (use-modules (guix build download)
+ (guix build utils)
+ (guix utils)
+ (web uri)
+ (ice-9 match)
+ (ice-9 popen))
+ ;; The code below expects tar to be in $PATH.
+ (set-path-environment-variable "PATH" '("bin")
+ (match '#+inputs
+ (((names dirs outputs ...) ...)
+ dirs)))
+
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
+
+ (call-with-temporary-directory
+ (lambda (directory)
+ ;; TODO: Support different archive types, based on content-type
+ ;; or archive name extention.
+ (let* ((file-to-extract (getenv "extract filename"))
+ (port (http-fetch (string->uri (getenv "download url"))
+ #:verify-certificate? #f))
+ (tar (open-pipe* OPEN_WRITE "tar" "-C" directory
+ "-xf" "-" file-to-extract)))
+ (dump-port port tar)
+ (close-port port)
+ (let ((status (close-pipe tar)))
+ (unless (zero? status)
+ (error "tar extraction failure" status)))
+ (copy-file (string-append directory "/"
+ (getenv "extract filename"))
+ #$output))))))))
+
+ (mlet %store-monad ((guile (package->derivation guile system)))
+ (gexp->derivation (or name file-name) build
+
+ ;; Use environment variables and a fixed script name so
+ ;; there's only one script in store for all the
+ ;; downloads.
+ #:script-name "extract-download"
+ #:env-vars
+ `(("download url" . ,url)
+ ("extract filename" . ,filename-to-extract))
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
+ #:system system
+ #:local-build? #t ; don't offload download
+ #:hash-algo hash-algo
+ #:hash hash
+ #:guile-for-build guile)))
+
+
+(define* (download-to-store/extract store url filename-to-extract
+ #:optional (name (basename url))
+ #:key (log (current-error-port))
+ (verify-certificate? #t))
+ "Download an archive from URL, and extracts FILE_TO_EXTRACT from the archive
+to STORE, either under NAME or URL's basename if omitted. Write progress
+reports to LOG. VERIFY-CERTIFICATE? determines whether or not to validate
+HTTPS server certificates."
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (let ((result
+ (parameterize ((current-output-port log))
+ (build:url-fetch url temp
+ ;;#:mirrors %mirrors
+ #:verify-certificate?
+ verify-certificate?))))
+ (close port)
+ (and result
+ (call-with-temporary-output-file
+ (lambda (contents port)
+ (let ((tar (open-pipe* OPEN_READ
+ "tar" ;"--auto-compress"
+ "-xf" temp "--to-stdout" filename-to-extract)))
+ (dump-port tar port)
+ (close-port port)
+ (let ((status (close-pipe tar)))
+ (unless (zero? status)
+ (error "tar extraction failure" status)))
+ (add-to-store store name #f "sha256" contents)))))))))
diff --git a/guix/git.scm b/guix/git.scm
index acc48fd12f..dc2ca1be84 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -34,8 +34,9 @@
#:use-module (guix records)
#:use-module (guix gexp)
#:use-module (guix sets)
- #:use-module ((guix diagnostics) #:select (leave))
+ #:use-module ((guix diagnostics) #:select (leave warning))
#:use-module (guix progress)
+ #:autoload (guix swh) (swh-download commit-id?)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
@@ -57,6 +58,8 @@
commit-difference
commit-relation
+ remote-refs
+
git-checkout
git-checkout?
git-checkout-url
@@ -180,6 +183,13 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables."
(lambda args
(make-fetch-options auth-method)))))
+(define GITERR_HTTP
+ ;; Guile-Git <= 0.5.2 lacks this constant.
+ (let ((errors (resolve-interface '(git errors))))
+ (if (module-defined? errors 'GITERR_HTTP)
+ (module-ref errors 'GITERR_HTTP)
+ 34)))
+
(define (clone* url directory)
"Clone git repository at URL into DIRECTORY. Upon failure,
make sure no empty directory is left behind."
@@ -332,7 +342,8 @@ dynamic extent of EXP."
"Return true if REF, a reference such as '(commit . \"cabba9e\"), is
definitely available in REPOSITORY, false otherwise."
(match ref
- (('commit . commit)
+ ((or ('commit . commit)
+ ('tag-or-commit . (? commit-id? commit)))
(let ((len (string-length commit))
(oid (string->oid commit)))
(false-if-git-not-found
@@ -342,6 +353,42 @@ definitely available in REPOSITORY, false otherwise."
(_
#f)))
+(define (clone-from-swh url tag-or-commit output)
+ "Attempt to clone TAG-OR-COMMIT (a string), which originates from URL, using
+a copy archived at Software Heritage."
+ (call-with-temporary-directory
+ (lambda (bare)
+ (and (swh-download url tag-or-commit bare
+ #:archive-type 'git-bare)
+ (let ((repository (clone* bare output)))
+ (remote-set-url! repository "origin" url)
+ repository)))))
+
+(define (clone/swh-fallback url ref cache-directory)
+ "Like 'clone', but fallback to Software Heritage if the repository cannot be
+found at URL."
+ (define (inaccessible-url-error? err)
+ (let ((class (git-error-class err))
+ (code (git-error-code err)))
+ (or (= class GITERR_HTTP) ;404 or similar
+ (= class GITERR_NET)))) ;unknown host, etc.
+
+ (catch 'git-error
+ (lambda ()
+ (clone* url cache-directory))
+ (lambda (key err)
+ (match ref
+ (((or 'commit 'tag-or-commit) . commit)
+ (if (inaccessible-url-error? err)
+ (or (clone-from-swh url commit cache-directory)
+ (begin
+ (warning (G_ "revision ~a of ~a \
+could not be fetched from Software Heritage~%")
+ commit url)
+ (throw key err)))
+ (throw key err)))
+ (_ (throw key err))))))
+
(define cached-checkout-expiration
;; Return the expiration time procedure for a cached checkout.
;; TODO: Honor $GUIX_GIT_CACHE_EXPIRATION.
@@ -408,7 +455,7 @@ it unchanged."
(let* ((cache-exists? (openable-repository? cache-directory))
(repository (if cache-exists?
(repository-open cache-directory)
- (clone* url cache-directory))))
+ (clone/swh-fallback url ref cache-directory))))
;; Only fetch remote if it has not been cloned just before.
(when (and cache-exists?
(not (reference-available? repository ref)))
@@ -571,6 +618,45 @@ objects: 'ancestor (meaning that OLD is an ancestor of NEW), 'descendant, or
(if (set-contains? oldest new)
'descendant
'unrelated))))))
+
+;;
+;;; Remote operations.
+;;;
+
+(define* (remote-refs url #:key tags?)
+ "Return the list of references advertised at Git repository URL. If TAGS?
+is true, limit to only refs/tags."
+ (define (ref? ref)
+ ;; Like `git ls-remote --refs', only show actual references.
+ (and (string-prefix? "refs/" ref)
+ (not (string-suffix? "^{}" ref))))
+
+ (define (tag? ref)
+ (string-prefix? "refs/tags/" ref))
+
+ (define (include? ref)
+ (and (ref? ref)
+ (or (not tags?) (tag? ref))))
+
+ (define (remote-head->ref remote)
+ (let ((name (remote-head-name remote)))
+ (and (include? name)
+ name)))
+
+ (with-libgit2
+ (call-with-temporary-directory
+ (lambda (cache-directory)
+ (let* ((repository (repository-init cache-directory))
+ ;; Create an in-memory remote so we don't touch disk.
+ (remote (remote-create-anonymous repository url)))
+ (remote-connect remote)
+
+ (let* ((remote-heads (remote-ls remote))
+ (refs (filter-map remote-head->ref remote-heads)))
+ ;; Wait until we're finished with the repository before closing it.
+ (remote-disconnect remote)
+ (repository-close! repository)
+ refs))))))
;;;
diff --git a/guix/graph.scm b/guix/graph.scm
index 0d4cd83667..3a1cab244b 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -337,11 +337,12 @@ nodeArray.push(nodes[\"~a\"]);~%"
(define* (export-graph sinks port
#:key
- reverse-edges? node-type
+ reverse-edges? node-type (max-depth +inf.0)
(backend %graphviz-backend))
"Write to PORT the representation of the DAG with the given SINKS, using the
given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is
-true, draw reverse arrows."
+true, draw reverse arrows. Do not represent nodes whose distance to one of
+the SINKS is greater than MAX-DEPTH."
(match backend
(($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
(emit-prologue (node-type-name node-type) port)
@@ -349,6 +350,7 @@ true, draw reverse arrows."
(match node-type
(($ <node-type> node-identifier node-label node-edges)
(let loop ((nodes sinks)
+ (depths (make-list (length sinks) 0))
(visited (set)))
(match nodes
(()
@@ -356,20 +358,29 @@ true, draw reverse arrows."
(emit-epilogue port)
(store-return #t)))
((head . tail)
- (mlet %store-monad ((id (node-identifier head)))
- (if (set-contains? visited id)
- (loop tail visited)
- (mlet* %store-monad ((dependencies (node-edges head))
- (ids (mapm %store-monad
- node-identifier
- dependencies)))
- (emit-node id (node-label head) port)
- (for-each (lambda (dependency dependency-id)
- (if reverse-edges?
- (emit-edge dependency-id id port)
- (emit-edge id dependency-id port)))
- dependencies ids)
- (loop (append dependencies tail)
- (set-insert id visited)))))))))))))
+ (match depths
+ ((depth . depths)
+ (mlet %store-monad ((id (node-identifier head)))
+ (if (set-contains? visited id)
+ (loop tail depths visited)
+ (mlet* %store-monad ((dependencies
+ (if (= depth max-depth)
+ (return '())
+ (node-edges head)))
+ (ids
+ (mapm %store-monad
+ node-identifier
+ dependencies)))
+ (emit-node id (node-label head) port)
+ (for-each (lambda (dependency dependency-id)
+ (if reverse-edges?
+ (emit-edge dependency-id id port)
+ (emit-edge id dependency-id port)))
+ dependencies ids)
+ (loop (append dependencies tail)
+ (append (make-list (length dependencies)
+ (+ 1 depth))
+ depths)
+ (set-insert id visited)))))))))))))))
;;; graph.scm ends here
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 287ffd2536..c76d7e9c1a 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr>
;;;
@@ -79,7 +79,10 @@
(number crate-version-number "num") ;string
(download-path crate-version-download-path "dl_path") ;string
(readme-path crate-version-readme-path "readme_path") ;string
- (license crate-version-license "license") ;string
+ (license crate-version-license "license" ;string | #f
+ (match-lambda
+ ('null #f)
+ ((? string? str) str)))
(links crate-version-links)) ;alist
;; Crate dependency. Each dependency (each edge in the graph) is annotated as
@@ -198,6 +201,7 @@ and LICENSE."
(description ,(beautify-description description))
(license ,(match license
(() #f)
+ (#f #f)
((license) license)
(_ `(list ,@license)))))))
(close-port port)
diff --git a/guix/import/git.scm b/guix/import/git.scm
new file mode 100644
index 0000000000..1eb219f3fe
--- /dev/null
+++ b/guix/import/git.scm
@@ -0,0 +1,225 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;;
+;;; 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 git)
+ #:use-module (guix build utils)
+ #:use-module (guix diagnostics)
+ #:use-module (guix git)
+ #:use-module (guix git-download)
+ #:use-module (guix i18n)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:export (%generic-git-updater
+
+ ;; For tests.
+ latest-git-tag-version))
+
+;;; Commentary:
+;;;
+;;; This module provides a generic package updater for packages hosted on Git
+;;; repositories.
+;;;
+;;; It tries to be smart about tag names, but if it is not automatically able
+;;; to parse the tag names correctly, users can set the `release-tag-prefix',
+;;; `release-tag-suffix' and `release-tag-version-delimiter' properties of the
+;;; package to make the updater parse the Git tag name correctly.
+;;;
+;;; Possible improvements:
+;;;
+;;; * More robust method for trying to guess the delimiter. Maybe look at the
+;;; previous version/tag combo to determine the delimiter.
+;;;
+;;; * Differentiate between "normal" versions, e.g., 1.2.3, and dates, e.g.,
+;;; 2021.12.31. Honor a `release-tag-date-scheme?' property?
+;;;
+;;; Code:
+
+;;; Errors & warnings
+
+(define-condition-type &git-no-valid-tags-error &error
+ git-no-valid-tags-error?)
+
+(define (git-no-valid-tags-error)
+ (raise (condition (&message (message "no valid tags found"))
+ (&git-no-valid-tags-error))))
+
+(define-condition-type &git-no-tags-error &error
+ git-no-tags-error?)
+
+(define (git-no-tags-error)
+ (raise (condition (&message (message "no tags were found"))
+ (&git-no-tags-error))))
+
+
+;;; Updater
+
+(define %pre-release-words
+ '("alpha" "beta" "rc" "dev" "test" "pre"))
+
+(define %pre-release-rx
+ (map (lambda (word)
+ (make-regexp (string-append ".+" word) regexp/icase))
+ %pre-release-words))
+
+(define* (version-mapping tags #:key prefix suffix delim pre-releases?)
+ "Given a list of Git TAGS, return an association list where the car is the
+version corresponding to the tag, and the cdr is the name of the tag."
+ (define (guess-delimiter)
+ (let ((total (length tags))
+ (dots (reduce + 0 (map (cut string-count <> #\.) tags)))
+ (dashes (reduce + 0 (map (cut string-count <> #\-) tags)))
+ (underscores (reduce + 0 (map (cut string-count <> #\_) tags))))
+ (cond
+ ((>= dots (* total 0.35)) ".")
+ ((>= dashes (* total 0.8)) "-")
+ ((>= underscores (* total 0.8)) "_")
+ (else ""))))
+
+ (define delim-rx (regexp-quote (or delim (guess-delimiter))))
+ (define suffix-rx (string-append (or suffix "") "$"))
+ (define prefix-rx (string-append "^" (or prefix "[^[:digit:]]*")))
+ (define pre-release-rx
+ (if pre-releases?
+ (string-append "(.*(" (string-join %pre-release-words "|") ").*)")
+ ""))
+
+ (define tag-rx
+ (string-append prefix-rx "([[:digit:]][^" delim-rx "[:punct:]]*"
+ "(" delim-rx "[^[:punct:]" delim-rx "]+)"
+ ;; If there are no delimiters, it could mean that the
+ ;; version just contains one number (e.g., "2"), thus, use
+ ;; "*" instead of "+" to match zero or more numbers.
+ (if (string=? delim-rx "") "*" "+") ")"
+ ;; We don't want the pre-release stuff (e.g., "-alpha") be
+ ;; part of the first group; otherwise, the "-" in "-alpha"
+ ;; might be interpreted as a delimiter, and thus replaced
+ ;; with "."
+ pre-release-rx suffix-rx))
+
+
+
+ (define (get-version tag)
+ (let ((tag-match (regexp-exec (make-regexp tag-rx) tag)))
+ (and=> (and tag-match
+ (regexp-substitute/global
+ #f delim-rx (match:substring tag-match 1)
+ ;; If there were no delimiters, don't insert ".".
+ 'pre (if (string=? delim-rx "") "" ".") 'post))
+ (lambda (version)
+ (if pre-releases?
+ (string-append version (match:substring tag-match 3))
+ version)))))
+
+ (define (entry<? a b)
+ (eq? (version-compare (car a) (car b)) '<))
+
+ (stable-sort (filter-map (lambda (tag)
+ (let ((version (get-version tag)))
+ (and version (cons version tag))))
+ tags)
+ entry<?))
+
+(define* (latest-tag url #:key prefix suffix delim pre-releases?)
+ "Return the latest version and corresponding tag available from the Git
+repository at URL."
+ (define (pre-release? tag)
+ (any (cut regexp-exec <> tag)
+ %pre-release-rx))
+
+ (let* ((tags (map (cut string-drop <> (string-length "refs/tags/"))
+ (remote-refs url #:tags? #t)))
+ (versions->tags
+ (version-mapping (if pre-releases?
+ tags
+ (filter (negate pre-release?) tags))
+ #:prefix prefix
+ #:suffix suffix
+ #:delim delim
+ #:pre-releases? pre-releases?)))
+ (cond
+ ((null? tags)
+ (git-no-tags-error))
+ ((null? versions->tags)
+ (git-no-valid-tags-error))
+ (else
+ (match (last versions->tags)
+ ((version . tag)
+ (values version tag)))))))
+
+(define (latest-git-tag-version package)
+ "Given a PACKAGE, return the latest version of it, or #f if the latest version
+could not be determined."
+ (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
+ (warning (or (package-field-location package 'source)
+ (package-location package))
+ (G_ "~a for ~a~%")
+ (condition-message c)
+ (package-name package))
+ #f)
+ ((eq? (exception-kind c) 'git-error)
+ (warning (or (package-field-location package 'source)
+ (package-location package))
+ (G_ "failed to fetch Git repository for ~a~%")
+ (package-name package))
+ #f))
+ (let* ((source (package-source package))
+ (url (git-reference-url (origin-uri source)))
+ (property (cute assq-ref (package-properties package) <>)))
+ (latest-tag url
+ #:prefix (property 'release-tag-prefix)
+ #:suffix (property 'release-tag-suffix)
+ #:delim (property 'release-tag-version-delimiter)
+ #:pre-releases? (property 'accept-pre-releases?)))))
+
+(define (git-package? package)
+ "Return true if PACKAGE is hosted on a Git repository."
+ (match (package-source package)
+ ((? origin? origin)
+ (and (eq? (origin-method origin) git-fetch)
+ (git-reference? (origin-uri origin))))
+ (_ #f)))
+
+(define (latest-git-release package)
+ "Return an <upstream-source> for the latest release of PACKAGE."
+ (let* ((name (package-name package))
+ (old-version (package-version package))
+ (url (git-reference-url (origin-uri (package-source package))))
+ (new-version (latest-git-tag-version package)))
+
+ (and new-version
+ (upstream-source
+ (package name)
+ (version new-version)
+ (urls (list url))))))
+
+(define %generic-git-updater
+ (upstream-updater
+ (name 'generic-git)
+ (description "Updater for packages hosted on Git repositories")
+ (pred git-package?)
+ (latest latest-git-release)))
diff --git a/guix/import/go.scm b/guix/import/go.scm
index c6ecdbaffd..26dbc34b63 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -474,13 +474,13 @@ Optionally include a VERSION string to append to the name."
because goproxy servers don't currently provide all the information needed to
build a package."
(define (go-import->module-meta content-text)
- (match (string-split content-text #\space)
+ (match (string-tokenize content-text char-set:graphic)
((root-path vcs repo-url)
(make-module-meta root-path (string->symbol vcs)
(strip-.git-suffix/maybe repo-url)))))
;; <meta name="go-import" content="import-prefix vcs repo-root">
(let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path)))
- (select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
+ (select (sxpath `(// (meta (@ (equal? (name "go-import"))))
// content))))
(match (select (html->sxml meta-data #:strict? #t))
(() #f) ;nothing selected
@@ -612,6 +612,8 @@ hint: use one of the following available versions ~a\n"
(dependencies (if pin-versions?
dependencies+versions
(map car dependencies+versions)))
+ (module-path-sans-suffix
+ (match:prefix (string-match "([\\./]v[0-9]+)?$" module-path)))
(guix-name (go-module->guix-package-name module-path))
(root-module-path (module-path->repository-root module-path))
;; The VCS type and URL are not included in goproxy information. For
@@ -619,7 +621,7 @@ hint: use one of the following available versions ~a\n"
(meta-data (fetch-module-meta-data root-module-path))
(vcs-type (module-meta-vcs meta-data))
(vcs-repo-url (module-meta-data-repo-url meta-data goproxy))
- (synopsis (go-package-synopsis root-module-path))
+ (synopsis (go-package-synopsis module-path))
(description (go-package-description module-path))
(licenses (go-package-licenses module-path)))
(values
@@ -630,7 +632,10 @@ hint: use one of the following available versions ~a\n"
,(vcs->origin vcs-type vcs-repo-url version*))
(build-system go-build-system)
(arguments
- '(#:import-path ,root-module-path))
+ '(#:import-path ,module-path
+ ,@(if (string=? module-path-sans-suffix root-module-path)
+ '()
+ `(#:unpack-path ,root-module-path))))
,@(maybe-propagated-inputs
(map (match-lambda
((name version)
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 7c6d9d0a22..d73fbe6a81 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -55,8 +55,8 @@
hackage-package?))
(define ghc-standard-libraries
- ;; List of libraries distributed with ghc (8.6.5).
- ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5.
+ ;; List of libraries distributed with ghc (as of 8.10.7).
+ ;; Contents of …-ghc-8.10.7/lib/ghc-8.10.7
'("ghc"
"cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but
;; hackage-name->package-name takes this into account.
@@ -68,6 +68,7 @@
"containers"
"deepseq"
"directory"
+ "exceptions"
"filepath"
"ghc"
"ghc-boot"
@@ -121,12 +122,12 @@ version is returned."
(string-append package-name-prefix (string-downcase name))))
(define guix-package->hackage-name
- (let ((uri-rx (make-regexp "https?://hackage.haskell.org/package/([^/]+)/.*"))
+ (let ((uri-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage)/package/([^/]+)/.*"))
(name-rx (make-regexp "(.*)-[0-9\\.]+")))
(lambda (package)
"Given a Guix package name, return the corresponding Hackage name."
(let* ((source-url (and=> (package-source package) origin-uri))
- (name (match:substring (regexp-exec uri-rx source-url) 1)))
+ (name (match:substring (regexp-exec uri-rx source-url) 2)))
(match (regexp-exec name-rx name)
(#f name)
(m (match:substring m 1)))))))
@@ -351,7 +352,7 @@ respectively."
#:guix-name hackage-name->package-name))
(define hackage-package?
- (let ((hackage-rx (make-regexp "https?://hackage.haskell.org")))
+ (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)")))
(url-predicate (cut regexp-exec hackage-rx <>))))
(define (latest-release package)
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index e1f8487b75..0f3ab473ca 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -25,6 +25,8 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module ((guix packages) #:prefix package:)
+ #:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (guix ui)
#:use-module (guix i18n)
@@ -36,15 +38,19 @@
#:use-module (json)
#:use-module (guix base32)
#:use-module (guix git)
+ #:use-module ((guix git-download) #:prefix download:)
#:use-module (guix store)
#:export (%default-sort-key
%contentdb-api
json->package
contentdb-fetch
elaborate-contentdb-name
+ minetest-package?
+ latest-minetest-release
minetest->guix-package
minetest-recursive-import
- sort-packages))
+ sort-packages
+ %minetest-updater))
;; The ContentDB API is documented at
;; <https://content.minetest.net>.
@@ -203,7 +209,7 @@ raise an exception."
(match correctly-named
((one) (package-keys-full-name one))
((too . many)
- (warning (G_ "~a is ambigious, presuming ~a (other options include: ~a)~%")
+ (warning (G_ "~a is ambiguous, presuming ~a (other options include: ~a)~%")
name (package-keys-full-name too)
(map package-keys-full-name many))
(package-keys-full-name too))
@@ -256,7 +262,7 @@ and possibly some other packages as well, or #f on failure."
(order "desc"))
"Search ContentDB for Q (a string). Sort by SORT, in ascending order
if ORDER is \"asc\" or descending order if ORDER is \"desc\". TYPE must
-be \"mod\", \"game\" or \"txp\", restricting thes search results to
+be \"mod\", \"game\" or \"txp\", restricting the search results to
respectively mods, games and texture packs. Limit to at most LIMIT
results. The return value is a list of <package-keys> records."
;; XXX does Guile have something for constructing (and, when necessary,
@@ -337,6 +343,25 @@ official Minetest forum and the Git repository (if any)."
(and=> (package-forums package) topic->url-sexp)
(package-repository package)))
+(define (release-version release)
+ "Guess the version of RELEASE from the release title."
+ (define title (release-title release))
+ (if (string-prefix? "v" title)
+ ;; Remove "v" prefix from release titles like ‘v1.0.1’.
+ (substring title 1)
+ title))
+
+(define (version-style version)
+ "Determine the kind of version number VERSION is -- a date, or a conventional
+conventional version number."
+ (define dots? (->bool (string-index version #\.)))
+ (define hyphens? (->bool (string-index version #\-)))
+ (match (cons dots? hyphens?)
+ ((#true . #false) 'regular) ; something like "0.1"
+ ((#false . #false) 'regular) ; single component version number
+ ((#true . #true) 'regular) ; result of 'git-version'
+ ((#false . #true) 'date))) ; something like "2021-01-25"
+
;; If the default sort key is changed, make sure to modify 'show-help'
;; in (guix scripts import minetest) appropriately as well.
(define %default-sort-key "score")
@@ -371,7 +396,11 @@ official Minetest forum and the Git repository (if any)."
DEPENDENCIES as a list of AUTHOR/NAME strings."
(define dependency-list
(assoc-ref dependencies author/name))
- (filter-map
+ ;; A mod can have multiple dependencies implemented by the same mod,
+ ;; so remove duplicate mod names.
+ (define (filter-deduplicate-map f list)
+ (delete-duplicates (filter-map f list)))
+ (filter-deduplicate-map
(lambda (dependency)
(and (not (dependency-optional? dependency))
(not (builtin-mod? (dependency-name dependency)))
@@ -432,7 +461,7 @@ list of AUTHOR/NAME strings."
(define important-upstream-dependencies
(important-dependencies dependencies author/name #:sort sort))
(values (make-minetest-sexp author/name
- (release-title release) ; version
+ (release-version release)
(package-repository package)
(release-commit release)
important-upstream-dependencies
@@ -454,3 +483,37 @@ list of AUTHOR/NAME strings."
(recursive-import author/name
#:repo->guix-package minetest->guix-package*
#:guix-name contentdb->package-name))
+
+(define (minetest-package? pkg)
+ "Is PKG a Minetest mod on ContentDB?"
+ (and (string-prefix? "minetest-" (package:package-name pkg))
+ (assq-ref (package:package-properties pkg) 'upstream-name)))
+
+(define (latest-minetest-release pkg)
+ "Return an <upstream-source> for the latest release of the package PKG,
+or #false if the latest release couldn't be determined."
+ (define author/name
+ (assq-ref (package:package-properties pkg) 'upstream-name))
+ (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f?
+ (define release (latest-release author/name))
+ (define source (package:package-source pkg))
+ (and contentdb-package release
+ (release-commit release) ; not always set
+ ;; Only continue if both the old and new version number are both
+ ;; dates or regular version numbers, as two different styles confuses
+ ;; the logic for determining which version is newer.
+ (eq? (version-style (release-version release))
+ (version-style (package:package-version pkg)))
+ (upstream-source
+ (package (package:package-name pkg))
+ (version (release-version release))
+ (urls (list (download:git-reference
+ (url (package-repository contentdb-package))
+ (commit (release-commit release))))))))
+
+(define %minetest-updater
+ (upstream-updater
+ (name 'minetest)
+ (description "Updater for Minetest packages on ContentDB")
+ (pred minetest-package?)
+ (latest latest-minetest-release)))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index f3619dcd9e..e2314820d0 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -9,6 +9,7 @@
;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -163,12 +164,13 @@ package on PyPI."
(hyphen-package-name->name+version
(basename (file-sans-extension url))))
- (match (and=> (package-source package) origin-uri)
- ((? string? url)
- (url->pypi-name url))
- ((lst ...)
- (any url->pypi-name lst))
- (#f #f)))
+ (or (assoc-ref (package-properties package) 'upstream-name)
+ (match (and=> (package-source package) origin-uri)
+ ((? string? url)
+ (url->pypi-name url))
+ ((lst ...)
+ (any url->pypi-name lst))
+ (#f #f))))
(define (wheel-url->extracted-directory wheel-url)
(match (string-split (basename wheel-url) #\-)
@@ -416,6 +418,11 @@ return the unaltered list of upstream dependency names."
description license)
"Return the `package' s-expression for a python package with the given NAME,
VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
+ (define (maybe-upstream-name name)
+ (if (string-match ".*\\-[0-9]+" (pk name))
+ `((properties ,`'(("upstream-name" . ,name))))
+ '()))
+
(call-with-temporary-output-file
(lambda (temp port)
(and (url-fetch source-url temp)
@@ -454,6 +461,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(sha256
(base32
,(guix-hash-url temp)))))
+ ,@(maybe-upstream-name name)
(build-system python-build-system)
,@(maybe-inputs required-inputs 'propagated-inputs)
,@(maybe-inputs native-inputs 'native-inputs)
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index bbd903a2cd..f58c6b163d 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -2,6 +2,8 @@
;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,9 +22,8 @@
(define-module (guix import stackage)
#:use-module (ice-9 match)
- #:use-module (ice-9 regex)
+ #:use-module (json)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (guix import json)
@@ -31,6 +32,8 @@
#:use-module (guix memoization)
#:use-module (guix packages)
#:use-module (guix upstream)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:export (%stackage-url
stackage->guix-package
stackage-recursive-import
@@ -44,15 +47,31 @@
(define %stackage-url
(make-parameter "https://www.stackage.org"))
-;; Latest LTS version compatible with GHC 8.6.5.
-(define %default-lts-version "14.27")
-
-(define (lts-info-packages lts-info)
- "Returns the alist of packages contained in LTS-INFO."
- (or (assoc-ref lts-info "packages") '()))
-
-(define (leave-with-message fmt . args)
- (raise (condition (&message (message (apply format #f fmt args))))))
+;; Latest LTS version compatible with current GHC.
+(define %default-lts-version "18.10")
+
+(define-json-mapping <stackage-lts> make-stackage-lts
+ stackage-lts?
+ json->stackage-lts
+ (snapshot stackage-lts-snapshot "snapshot" json->snapshot)
+ (packages stackage-lts-packages "packages"
+ (lambda (vector)
+ (map json->stackage-package (vector->list vector)))))
+
+(define-json-mapping <snapshot> make-snapshot
+ stackage-snapshot?
+ json->snapshot
+ (name snapshot-name)
+ (ghc-version snapshot-ghc-version)
+ (compiler snapshot-compiler))
+
+(define-json-mapping <stackage-package> make-stackage-package
+ stackage-package?
+ json->stackage-package
+ (origin stackage-package-origin)
+ (name stackage-package-name)
+ (version stackage-package-version)
+ (synopsis stackage-package-synopsis))
(define stackage-lts-info-fetch
;; "Retrieve the information about the LTS Stackage release VERSION."
@@ -62,21 +81,15 @@
"/lts-" (if (string-null? version)
%default-lts-version
version)))
- (lts-info (json-fetch url)))
- (if lts-info
- (reverse lts-info)
- (leave-with-message "LTS release version not found: ~a" version))))))
-
-(define (stackage-package-name pkg-info)
- (assoc-ref pkg-info "name"))
-
-(define (stackage-package-version pkg-info)
- (assoc-ref pkg-info "version"))
+ (lts-info (and=> (json-fetch url) json->stackage-lts)))
+ (or lts-info
+ (raise (formatted-message (G_ "LTS release version not found: ~a")
+ version)))))))
-(define (lts-package-version pkgs-info name)
- "Return the version of the package with upstream NAME included in PKGS-INFO."
+(define (lts-package-version packages name)
+ "Return the version of the package with upstream NAME included in PACKAGES."
(let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
- (vector->list pkgs-info))))
+ packages)))
(stackage-package-version pkg)))
@@ -93,21 +106,22 @@
#:key
(include-test-dependencies? #t)
(lts-version %default-lts-version)
- (packages-info
- (lts-info-packages
+ (packages
+ (stackage-lts-packages
(stackage-lts-info-fetch lts-version))))
"Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved
version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
release at stackage.org. Return the `package' S-expression corresponding to
that package, or #f on failure. PACKAGES-INFO is the alist with the packages
included in the Stackage LTS release."
- (let* ((version (lts-package-version packages-info package-name))
+ (let* ((version (lts-package-version packages package-name))
(name-version (hackage-name-version package-name version)))
(if name-version
(hackage->guix-package name-version
#:include-test-dependencies?
include-test-dependencies?)
- (leave-with-message "~a: Stackage package not found" package-name))))))
+ (raise (formatted-message (G_ "~a: Stackage package not found")
+ package-name)))))))
(define (stackage-recursive-import package-name . args)
(recursive-import package-name
@@ -121,31 +135,46 @@ included in the Stackage LTS release."
;;;
(define latest-lts-release
- (let ((pkgs-info
- (mlambda () (lts-info-packages
- (stackage-lts-info-fetch %default-lts-version)))))
- (lambda* (package)
+ (let ((packages
+ (mlambda ()
+ (stackage-lts-packages
+ (stackage-lts-info-fetch %default-lts-version)))))
+ (lambda* (pkg)
"Return an <upstream-source> for the latest Stackage LTS release of
PACKAGE or #f if the package is not included in the Stackage LTS release."
- (let* ((hackage-name (guix-package->hackage-name package))
- (version (lts-package-version (pkgs-info) hackage-name))
+ (let* ((hackage-name (guix-package->hackage-name pkg))
+ (version (lts-package-version (packages) hackage-name))
(name-version (hackage-name-version hackage-name version)))
(match (and=> name-version hackage-fetch)
- (#f (format (current-error-port)
- "warning: failed to parse ~a~%"
- (hackage-cabal-url hackage-name))
- #f)
+ (#f
+ (warning (G_ "failed to parse ~a~%")
+ (hackage-cabal-url hackage-name))
+ #f)
(_ (let ((url (hackage-source-url hackage-name version)))
(upstream-source
- (package (package-name package))
+ (package (package-name pkg))
(version version)
- (urls (list url))))))))))
+ (urls (list url))
+ (input-changes
+ (changed-inputs
+ pkg
+ (stackage->guix-package hackage-name #:packages (packages))))))))))))
+
+(define (stackage-lts-package? package)
+ "Return whether PACKAGE is available on the default Stackage LTS release."
+ (and (hackage-package? package)
+ (let ((packages (stackage-lts-packages
+ (stackage-lts-info-fetch %default-lts-version)))
+ (hackage-name (guix-package->hackage-name package)))
+ (find (lambda (package)
+ (string=? (stackage-package-name package) hackage-name))
+ packages))))
(define %stackage-updater
(upstream-updater
(name 'stackage)
(description "Updater for Stackage LTS packages")
- (pred hackage-package?)
+ (pred stackage-lts-package?)
(latest latest-lts-release)))
;;; stackage.scm ends here
diff --git a/guix/packages.scm b/guix/packages.scm
index 3953b7f79b..fa23cc39b3 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
@@ -363,6 +363,27 @@ name of its URI."
;; git, svn, cvs, etc. reference
#f))))
+;; Work around limitations in the 'snippet' mechanism. It is not possible for
+;; a 'snippet' to produce a tarball with a different base name than the
+;; original downloaded source. Moreover, cherry picking dozens of upsteam
+;; patches and applying them suddenly is often impractical; especially when a
+;; comprehensive code reformatting is done upstream. Mainly designed for
+;; Linux and IceCat packages.
+;; XXXX: do not make part of public API (export) such radical capability
+;; before a detailed review process.
+(define* (computed-origin-method gexp-promise hash-algo hash
+ #:optional (name "source")
+ #:key (system (%current-system))
+ (guile (default-guile)))
+ "Return a derivation that executes the G-expression that results
+from forcing GEXP-PROMISE."
+ (mlet %store-monad ((guile (package->derivation guile system)))
+ (gexp->derivation (or name "computed-origin")
+ (force gexp-promise)
+ #:graft? #f ;nothing to graft
+ #:system system
+ #:guile-for-build guile)))
+
(define %supported-systems
;; This is the list of system types that are supported. By default, we
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 66de824ef4..439fae0b52 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -500,6 +500,10 @@ package modules, while attempting to retain user package modules."
(lambda (opt name arg result)
(alist-cons 'backend (lookup-backend arg)
result)))
+ (option '(#\M "max-depth") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'max-depth (string->number* arg)
+ result)))
(option '("list-backends") #f #f
(lambda (opt name arg result)
(list-backends)
@@ -538,6 +542,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(display (G_ "
--list-types list the available graph types"))
(display (G_ "
+ --max-depth=DEPTH limit to nodes within distance DEPTH"))
+ (display (G_ "
--path display the shortest path between the given nodes"))
(display (G_ "
-e, --expression=EXPR consider the package EXPR evaluates to"))
@@ -559,6 +565,7 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(define %default-options
`((node-type . ,%package-node-type)
(backend . ,%graphviz-backend)
+ (max-depth . +inf.0)
(system . ,(%current-system))))
@@ -582,6 +589,7 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
(with-store store
(let* ((transform (options->transformation opts))
+ (max-depth (assoc-ref opts 'max-depth))
(items (filter-map (match-lambda
(('argument . (? store-path? item))
item)
@@ -613,7 +621,8 @@ nodes (given ~a)~%")
(export-graph (concatenate nodes)
(current-output-port)
#:node-type type
- #:backend backend)))
+ #:backend backend
+ #:max-depth max-depth)))
#:system (assq-ref opts 'system)))))
#t)
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
new file mode 100644
index 0000000000..55e7b436c1
--- /dev/null
+++ b/guix/scripts/home.scm
@@ -0,0 +1,524 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com>
+;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.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 scripts home)
+ #:use-module (gnu packages admin)
+ #:use-module ((gnu services) #:hide (delete))
+ #:use-module (gnu packages)
+ #:use-module (gnu home)
+ #:use-module (gnu home services)
+ #:use-module (guix channels)
+ #:use-module (guix derivations)
+ #:use-module (guix ui)
+ #:use-module (guix grafts)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix scripts package)
+ #:use-module (guix scripts build)
+ #:use-module (guix scripts system search)
+ #:autoload (guix scripts pull) (channel-commit-hyperlink)
+ #:use-module (guix scripts home import)
+ #:use-module ((guix status) #:select (with-status-verbosity))
+ #:use-module (guix gexp)
+ #:use-module (guix monads)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 match)
+ #:export (guix-home))
+
+
+;;;
+;;; Options.
+;;;
+
+(define %user-module
+ (make-user-module '((gnu home))))
+
+(define %guix-home
+ (string-append %profile-directory "/guix-home"))
+
+(define (show-help)
+ (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE]
+Build the home environment declared in FILE according to ACTION.
+Some ACTIONS support additional ARGS.\n"))
+ (newline)
+ (display (G_ "The valid values for ACTION are:\n"))
+ (newline)
+ (display (G_ "\
+ search search for existing service types\n"))
+ (display (G_ "\
+ reconfigure switch to a new home environment configuration\n"))
+ (display (G_ "\
+ roll-back switch to the previous home environment configuration\n"))
+ (display (G_ "\
+ describe describe the current home environment\n"))
+ (display (G_ "\
+ list-generations list the home environment generations\n"))
+ (display (G_ "\
+ switch-generation switch to an existing home environment configuration\n"))
+ (display (G_ "\
+ delete-generations delete old home environment generations\n"))
+ (display (G_ "\
+ build build the home environment without installing anything\n"))
+ (display (G_ "\
+ import generates a home environment definition from dotfiles\n"))
+
+ (show-build-options-help)
+ (display (G_ "
+ -e, --expression=EXPR consider the home-environment EXPR evaluates to
+ instead of reading FILE, when applicable"))
+ (display (G_ "
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define (verbosity-level opts)
+ "Return the verbosity level based on OPTS, the alist of parsed options."
+ (or (assoc-ref opts 'verbosity)
+ (if (eq? (assoc-ref opts 'action) 'build)
+ 2 1)))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\n "dry-run") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'dry-run? #t result)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix show")))
+ (option '(#\v "verbosity") #t #f
+ (lambda (opt name arg result)
+ (let ((level (string->number* arg)))
+ (alist-cons 'verbosity level
+ (alist-delete 'verbosity result)))))
+ (option '(#\e "expression") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'expression arg result)))
+ %standard-build-options))
+
+(define %default-options
+ `((build-mode . ,(build-mode normal))
+ (graft? . #t)
+ (substitutes? . #t)
+ (offload? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
+ (verbosity . 3)
+ (debug . 0)))
+
+
+;;;
+;;; Actions.
+;;;
+
+(define* (perform-action action he
+ #:key
+ dry-run?
+ derivations-only?
+ use-substitutes?)
+ "Perform ACTION for home environment. "
+
+ (define println
+ (cut format #t "~a~%" <>))
+
+ (mlet* %store-monad
+ ((he-drv (home-environment-derivation he))
+ (drvs (mapm/accumulate-builds lower-object (list he-drv)))
+ (% (if derivations-only?
+ (return
+ (for-each (compose println derivation-file-name) drvs))
+ (built-derivations drvs)))
+
+ (he-out-path -> (derivation->output-path he-drv)))
+ (if (or dry-run? derivations-only?)
+ (return #f)
+ (begin
+ (for-each (compose println derivation->output-path) drvs)
+
+ (case action
+ ((reconfigure)
+ (let* ((number (generation-number %guix-home))
+ (generation (generation-file-name
+ %guix-home (+ 1 number))))
+
+ (switch-symlinks generation he-out-path)
+ (switch-symlinks %guix-home generation)
+ (setenv "GUIX_NEW_HOME" he-out-path)
+ (primitive-load (string-append he-out-path "/activate"))
+ (setenv "GUIX_NEW_HOME" #f)
+ (return he-out-path)))
+ (else
+ (newline)
+ (return he-out-path)))))))
+
+(define (process-action action args opts)
+ "Process ACTION, a sub-command, with the arguments are listed in ARGS.
+ACTION must be one of the sub-commands that takes a home environment
+declaration as an argument (a file name.) OPTS is the raw alist of options
+resulting from command-line parsing."
+ (define (ensure-home-environment file-or-exp obj)
+ (ensure-profile-directory)
+ (unless (home-environment? obj)
+ (leave (G_ "'~a' does not return a home environment ~%")
+ file-or-exp))
+ obj)
+
+ (let* ((file (match args
+ (() #f)
+ ((x . _) x)))
+ (expr (assoc-ref opts 'expression))
+ (system (assoc-ref opts 'system))
+
+ (transform (lambda (obj)
+ (home-environment-with-provenance obj file)))
+
+ (home-environment
+ (transform
+ (ensure-home-environment
+ (or file expr)
+ (cond
+ ((and expr file)
+ (leave
+ (G_ "both file and expression cannot be specified~%")))
+ (expr
+ (read/eval expr))
+ (file
+ (load* file %user-module
+ #:on-error (assoc-ref opts 'on-error)))
+ (else
+ (leave (G_ "no configuration specified~%")))))))
+
+ (dry? (assoc-ref opts 'dry-run?)))
+
+ (with-store store
+ (set-build-options-from-command-line store opts)
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:verbosity
+ (verbosity-level opts)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+
+ (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+
+ (case action
+ (else
+ (perform-action action home-environment
+ #:dry-run? dry?
+ #:derivations-only? (assoc-ref opts 'derivations-only?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?))
+ ))))))
+ (warn-about-disk-space)))
+
+
+(define (process-command command args opts)
+ "Process COMMAND, one of the 'guix home' sub-commands. ARGS is its
+argument list and OPTS is the option alist."
+ (define-syntax-rule (with-store* store exp ...)
+ (with-store store
+ (set-build-options-from-command-line store opts)
+ exp ...))
+ (case command
+ ;; The following commands do not need to use the store, and they do not need
+ ;; an home environment file.
+ ((search)
+ (apply search args))
+ ((import)
+ (let* ((profiles (delete-duplicates
+ (match (filter-map (match-lambda
+ (('profile . p) p)
+ (_ #f))
+ opts)
+ (() (list %current-profile))
+ (lst (reverse lst)))))
+ (manifest (concatenate-manifests
+ (map profile-manifest profiles))))
+ (import-manifest manifest (current-output-port))))
+ ((describe)
+ (match (generation-number %guix-home)
+ (0
+ (error (G_ "no home environment generation, nothing to describe~%")))
+ (generation
+ (display-home-environment-generation generation))))
+ ((list-generations)
+ (let ((pattern (match args
+ (() #f)
+ ((pattern) pattern)
+ (x (leave (G_ "wrong number of arguments~%"))))))
+ (list-generations pattern)))
+ ((switch-generation)
+ (let ((pattern (match args
+ ((pattern) pattern)
+ (x (leave (G_ "wrong number of arguments~%"))))))
+ (with-store* store
+ (switch-to-home-environment-generation store pattern))))
+ ((roll-back)
+ (let ((pattern (match args
+ (() "")
+ (x (leave (G_ "wrong number of arguments~%"))))))
+ (with-store* store
+ (roll-back-home-environment store))))
+ ((delete-generations)
+ (let ((pattern (match args
+ (() #f)
+ ((pattern) pattern)
+ (x (leave (G_ "wrong number of arguments~%"))))))
+ (with-store*
+ store
+ (delete-matching-generations store %guix-home pattern))))
+ (else (process-action command args opts))))
+
+(define-command (guix-home . args)
+ (synopsis "build and deploy home environments")
+
+ (define (parse-sub-command arg result)
+ ;; Parse sub-command ARG and augment RESULT accordingly.
+ (if (assoc-ref result 'action)
+ (alist-cons 'argument arg result)
+ (let ((action (string->symbol arg)))
+ (case action
+ ((build
+ reconfigure
+ extension-graph shepherd-graph
+ list-generations describe
+ delete-generations roll-back
+ switch-generation search
+ import)
+ (alist-cons 'action action result))
+ (else (leave (G_ "~a: unknown action~%") action))))))
+
+ (define (match-pair car)
+ ;; Return a procedure that matches a pair with CAR.
+ (match-lambda
+ ((head . tail)
+ (and (eq? car head) tail))
+ (_ #f)))
+
+ (define (option-arguments opts)
+ ;; Extract the plain arguments from OPTS.
+ (let* ((args (reverse (filter-map (match-pair 'argument) opts)))
+ (count (length args))
+ (action (assoc-ref opts 'action))
+ (expr (assoc-ref opts 'expression)))
+ (define (fail)
+ (leave (G_ "wrong number of arguments for action '~a'~%")
+ action))
+
+ (unless action
+ (format (current-error-port)
+ (G_ "guix home: missing command name~%"))
+ (format (current-error-port)
+ (G_ "Try 'guix home --help' for more information.~%"))
+ (exit 1))
+
+ (case action
+ ((build reconfigure)
+ (unless (or (= count 1)
+ (and expr (= count 0)))
+ (fail)))
+ ((init)
+ (unless (= count 2)
+ (fail))))
+ args))
+
+ (with-error-handling
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)
+ #:argument-handler
+ parse-sub-command))
+ (args (option-arguments opts))
+ (command (assoc-ref opts 'action)))
+ (parameterize ((%graft? (assoc-ref opts 'graft?)))
+ (with-status-verbosity (verbosity-level opts)
+ (process-command command args opts))))))
+
+
+;;;
+;;; Searching.
+;;;
+
+(define service-type-name*
+ (compose symbol->string service-type-name))
+
+(define (service-type-description-string type)
+ "Return the rendered and localised description of TYPE, a service type."
+ (and=> (service-type-description type)
+ (compose texi->plain-text P_)))
+
+(define %service-type-metrics
+ ;; Metrics used to estimate the relevance of a search result.
+ `((,service-type-name* . 3)
+ (,service-type-description-string . 2)
+ (,(lambda (type)
+ (match (and=> (service-type-location type) location-file)
+ ((? string? file)
+ (basename file ".scm"))
+ (#f
+ "")))
+ . 1)))
+
+(define (find-service-types regexps)
+ "Return a list of service type/score pairs: service types whose name or
+description matches REGEXPS sorted by relevance, and their score."
+ (let ((matches (fold-home-service-types
+ (lambda (type result)
+ (match (relevance type regexps
+ %service-type-metrics)
+ ((? zero?)
+ result)
+ (score
+ (cons (cons type score) result))))
+ '())))
+ (sort matches
+ (lambda (m1 m2)
+ (match m1
+ ((type1 . score1)
+ (match m2
+ ((type2 . score2)
+ (if (= score1 score2)
+ (string>? (service-type-name* type1)
+ (service-type-name* type2))
+ (> score1 score2))))))))))
+
+(define (search . args)
+ (with-error-handling
+ (let* ((regexps (map (cut make-regexp* <> regexp/icase) args))
+ (matches (find-service-types regexps)))
+ (leave-on-EPIPE
+ (display-search-results matches (current-output-port)
+ #:print service-type->recutils
+ #:command "guix home search")))))
+
+
+;;;
+;;; Generations.
+;;;
+
+(define* (display-home-environment-generation
+ number
+ #:optional (profile %guix-home))
+ "Display a summary of home-environment generation NUMBER in a
+human-readable format."
+ (define (display-channel channel)
+ (format #t " ~a:~%" (channel-name channel))
+ (format #t (G_ " repository URL: ~a~%") (channel-url channel))
+ (when (channel-branch channel)
+ (format #t (G_ " branch: ~a~%") (channel-branch channel)))
+ (format #t (G_ " commit: ~a~%")
+ (if (supports-hyperlinks?)
+ (channel-commit-hyperlink channel)
+ (channel-commit channel))))
+
+ (unless (zero? number)
+ (let* ((generation (generation-file-name profile number)))
+ (define-values (channels config-file)
+ ;; The function will work for home environments too, we just
+ ;; need to keep provenance file.
+ (system-provenance generation))
+
+ (display-generation profile number)
+ (format #t (G_ " file name: ~a~%") generation)
+ (format #t (G_ " canonical file name: ~a~%") (readlink* generation))
+ ;; TRANSLATORS: Please preserve the two-space indentation.
+
+ (unless (null? channels)
+ ;; TRANSLATORS: Here "channel" is the same terminology as used in
+ ;; "guix describe" and "guix pull --channels".
+ (format #t (G_ " channels:~%"))
+ (for-each display-channel channels))
+ (when config-file
+ (format #t (G_ " configuration file: ~a~%")
+ (if (supports-hyperlinks?)
+ (file-hyperlink config-file)
+ config-file))))))
+
+(define* (list-generations pattern #:optional (profile %guix-home))
+ "Display in a human-readable format all the home environment
+generations matching PATTERN, a string. When PATTERN is #f, display
+all the home environment generations."
+ (cond ((not (file-exists? profile)) ; XXX: race condition
+ (raise (condition (&profile-not-found-error
+ (profile profile)))))
+ ((not pattern)
+ (for-each display-home-environment-generation (profile-generations profile)))
+ ((matching-generations pattern profile)
+ =>
+ (lambda (numbers)
+ (if (null-list? numbers)
+ (exit 1)
+ (leave-on-EPIPE
+ (for-each display-home-environment-generation numbers)))))))
+
+
+;;;
+;;; Switch generations.
+;;;
+
+;; TODO: Make it public in (guix scripts system)
+(define-syntax-rule (unless-file-not-found exp)
+ (catch 'system-error
+ (lambda ()
+ exp)
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ #f
+ (apply throw args)))))
+
+(define (switch-to-home-environment-generation store spec)
+ "Switch the home-environment profile to the generation specified by
+SPEC. STORE is an open connection to the store."
+ (let* ((number (relative-generation-spec->number %guix-home spec))
+ (generation (generation-file-name %guix-home number))
+ (activate (string-append generation "/activate")))
+ (if number
+ (begin
+ (setenv "GUIX_NEW_HOME" (readlink generation))
+ (switch-to-generation* %guix-home number)
+ (unless-file-not-found (primitive-load activate))
+ (setenv "GUIX_NEW_HOME" #f))
+ (leave (G_ "cannot switch to home environment generation '~a'~%") spec))))
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-home-environment store)
+ "Roll back the home-environment profile to its previous generation.
+STORE is an open connection to the store."
+ (switch-to-home-environment-generation store "-1"))
diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
new file mode 100644
index 0000000000..611f580e85
--- /dev/null
+++ b/guix/scripts/home/import.scm
@@ -0,0 +1,243 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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 scripts home import)
+ #:use-module (guix profiles)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (gnu packages)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (import-manifest))
+
+;;; Commentary:
+;;;
+;;; This module provides utilities for generating home service
+;;; configurations from existing "dotfiles".
+;;;
+;;; Code:
+
+
+(define (generate-bash-module+configuration)
+ (let ((rc (string-append (getenv "HOME") "/.bashrc"))
+ (profile (string-append (getenv "HOME") "/.bash_profile"))
+ (logout (string-append (getenv "HOME") "/.bash_logout")))
+ `((gnu home services bash)
+ (service home-bash-service-type
+ (home-bash-configuration
+ ,@(if (file-exists? rc)
+ `((bashrc
+ (list (local-file ,rc))))
+ '())
+ ,@(if (file-exists? profile)
+ `((bash-profile
+ (list (local-file ,profile))))
+ '())
+ ,@(if (file-exists? logout)
+ `((bash-logout
+ (list (local-file ,logout))))
+ '()))))))
+
+
+(define %files-configurations-alist
+ `((".bashrc" . ,generate-bash-module+configuration)
+ (".bash_profile" . ,generate-bash-module+configuration)
+ (".bash_logout" . ,generate-bash-module+configuration)))
+
+(define (modules+configurations)
+ (let ((configurations (delete-duplicates
+ (filter-map (match-lambda
+ ((file . proc)
+ (if (file-exists?
+ (string-append (getenv "HOME") "/" file))
+ proc
+ #f)))
+ %files-configurations-alist)
+ (lambda (x y)
+ (equal? (procedure-name x) (procedure-name y))))))
+ (map (lambda (proc) (proc)) configurations)))
+
+;; Based on `manifest->code' from (guix profiles)
+;; MAYBE: Upstream it?
+(define* (manifest->code manifest
+ #:key
+ (entry-package-version (const ""))
+ (home-environment? #f))
+ "Return an sexp representing code to build an approximate version of
+MANIFEST; the code is wrapped in a top-level 'begin' form. If
+HOME-ENVIRONMENT? is #t, return an <home-environment> definition.
+Call ENTRY-PACKAGE-VERSION to determine the version number to use in
+the spec for a given entry; it can be set to 'manifest-entry-version'
+for fully-specified version numbers, or to some other procedure to
+disambiguate versions for packages for which several versions are
+available."
+ (define (entry-transformations entry)
+ ;; Return the transformations that apply to ENTRY.
+ (assoc-ref (manifest-entry-properties entry) 'transformations))
+
+ (define transformation-procedures
+ ;; List of transformation options/procedure name pairs.
+ (let loop ((entries (manifest-entries manifest))
+ (counter 1)
+ (result '()))
+ (match entries
+ (() result)
+ ((entry . tail)
+ (match (entry-transformations entry)
+ (#f
+ (loop tail counter result))
+ (options
+ (if (assoc-ref result options)
+ (loop tail counter result)
+ (loop tail (+ 1 counter)
+ (alist-cons options
+ (string->symbol
+ (format #f "transform~a" counter))
+ result)))))))))
+
+ (define (qualified-name entry)
+ ;; Return the name of ENTRY possibly with "@" followed by a version.
+ (match (entry-package-version entry)
+ ("" (manifest-entry-name entry))
+ (version (string-append (manifest-entry-name entry)
+ "@" version))))
+
+ (if (null? transformation-procedures)
+ (let ((specs (map (lambda (entry)
+ (match (manifest-entry-output entry)
+ ("out" (qualified-name entry))
+ (output (string-append (qualified-name entry)
+ ":" output))))
+ (manifest-entries manifest))))
+ (if home-environment?
+ (let ((modules+configurations (modules+configurations)))
+ `(begin
+ (use-modules (gnu home)
+ (gnu packages)
+ ,@(map first modules+configurations))
+ ,(home-environment-template
+ #:specs specs
+ #:services (map second modules+configurations))))
+ `(begin
+ (use-modules (gnu packages))
+
+ (specifications->manifest
+ (list ,@specs)))))
+ (let* ((transform (lambda (options exp)
+ (if (not options)
+ exp
+ (let ((proc (assoc-ref transformation-procedures
+ options)))
+ `(,proc ,exp)))))
+ (packages (map (lambda (entry)
+ (define options
+ (entry-transformations entry))
+
+ (define name
+ (qualified-name entry))
+
+ (match (manifest-entry-output entry)
+ ("out"
+ (transform options
+ `(specification->package ,name)))
+ (output
+ `(list ,(transform
+ options
+ `(specification->package ,name))
+ ,output))))
+ (manifest-entries manifest)))
+ (transformations (map (match-lambda
+ ((options . name)
+ `(define ,name
+ (options->transformation ',options))))
+ transformation-procedures)))
+ (if home-environment?
+ (let ((modules+configurations (modules+configurations)))
+ `(begin
+ (use-modules (guix transformations)
+ (gnu home)
+ (gnu packages)
+ ,@(map first modules+configurations))
+
+ ,@transformations
+
+ ,(home-environment-template
+ #:packages packages
+ #:services (map second modules+configurations))))
+ `(begin
+ (use-modules (guix transformations)
+ (gnu packages))
+
+ ,@transformations
+
+ (packages->manifest
+ (list ,@packages)))))))
+
+(define* (home-environment-template #:key (packages #f) (specs #f) services)
+ "Return an S-exp containing a <home-environment> declaration
+containing PACKAGES, or SPECS (package specifications), and SERVICES."
+ `(home-environment
+ (packages
+ ,@(if packages
+ `((list ,@packages))
+ `((map specification->package
+ (list ,@specs)))))
+ (services (list ,@services))))
+
+(define* (import-manifest
+ manifest
+ #:optional (port (current-output-port)))
+ "Write to PORT a <home-environment> corresponding to MANIFEST."
+ (define (version-spec entry)
+ (let ((name (manifest-entry-name entry)))
+ (match (map package-version (find-packages-by-name name))
+ ((_)
+ ;; A single version of NAME is available, so do not specify the
+ ;; version number, even if the available version doesn't match ENTRY.
+ "")
+ (versions
+ ;; If ENTRY uses the latest version, don't specify any version.
+ ;; Otherwise return the shortest unique version prefix. Note that
+ ;; this is based on the currently available packages, which could
+ ;; differ from the packages available in the revision that was used
+ ;; to build MANIFEST.
+ (let ((current (manifest-entry-version entry)))
+ (if (every (cut version>? current <>)
+ (delete current versions))
+ ""
+ (version-unique-prefix (manifest-entry-version entry)
+ versions)))))))
+
+ (match (manifest->code manifest
+ #:entry-package-version version-spec
+ #:home-environment? #t)
+ (('begin exp ...)
+ (format port (G_ "\
+;; This \"home-environment\" file can be passed to 'guix home reconfigure'
+;; to reproduce the content of your profile. This is \"symbolic\": it only
+;; specifies package names. To reproduce the exact same profile, you also
+;; need to capture the channels being used, as returned by \"guix describe\".
+;; See the \"Replicating Guix\" section in the manual.\n"))
+ (for-each (lambda (exp)
+ (newline port)
+ (pretty-print exp port))
+ exp))))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 25846b7dc2..6e2b4368da 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -25,6 +25,7 @@
#:use-module ((system repl server) #:prefix repl:)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 format)
+ #:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 poll)
#:use-module (ice-9 regex)
@@ -400,15 +401,18 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs."
(let ((store-path (hash-part->path store hash)))
(if (string-null? store-path)
(not-found request #:phrase "" #:ttl negative-ttl)
- (values `((content-type . (application/x-nix-narinfo))
+ (values `((content-type . (application/x-nix-narinfo
+ (charset . "UTF-8")))
+ (x-nar-path . ,nar-path)
+ (x-narinfo-compressions . ,compressions)
,@(if ttl
`((cache-control (max-age . ,ttl)))
'()))
- (cut display
- (narinfo-string store store-path
- #:nar-path nar-path
- #:compressions compressions)
- <>)))))
+ ;; Do not call narinfo-string directly here as it is an
+ ;; expensive call that could potentially block the main
+ ;; thread. Instead, create the narinfo string in the
+ ;; http-write procedure.
+ store-path))))
(define* (nar-cache-file directory item
#:key (compression %no-compression))
@@ -663,19 +667,38 @@ requested using POOL."
(link narinfo other)))
others))))))
+(define (compression->sexp compression)
+ "Return the SEXP representation of COMPRESSION."
+ (match compression
+ (($ <compression> type level)
+ `(compression ,type ,level))))
+
+(define (sexp->compression sexp)
+ "Turn the given SEXP into a <compression> record and return it."
+ (match sexp
+ (('compression type level)
+ (compression type level))))
+
;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for
;; internal consumption: it allows us to pass the compression info to
;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>.
(declare-header! "X-Nar-Compression"
(lambda (str)
- (match (call-with-input-string str read)
- (('compression type level)
- (compression type level))))
+ (sexp->compression
+ (call-with-input-string str read)))
compression?
(lambda (compression port)
- (match compression
- (($ <compression> type level)
- (write `(compression ,type ,level) port)))))
+ (write (compression->sexp compression) port)))
+
+;; This header is used to pass the supported compressions to http-write in
+;; order to format on-the-fly narinfo responses.
+(declare-header! "X-Narinfo-Compressions"
+ (lambda (str)
+ (map sexp->compression
+ (call-with-input-string str read)))
+ (cut every compression? <>)
+ (lambda (compressions port)
+ (write (map compression->sexp compressions) port)))
(define* (render-nar store request store-item
#:key (compression %no-compression))
@@ -830,7 +853,8 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
"Return RESPONSE's headers minus 'Content-Length' and our internal headers."
(fold alist-delete
(response-headers response)
- '(content-length x-raw-file x-nar-compression)))
+ '(content-length x-raw-file x-nar-compression
+ x-narinfo-compressions x-nar-path)))
(define (sans-content-length response)
"Return RESPONSE without its 'content-length' header."
@@ -964,6 +988,38 @@ blocking."
(unless keep-alive?
(close-port client)))
(values))))))
+ (('application/x-nix-narinfo . _)
+ (let ((compressions (assoc-ref (response-headers response)
+ 'x-narinfo-compressions))
+ (nar-path (assoc-ref (response-headers response)
+ 'x-nar-path)))
+ (if nar-path
+ (begin
+ (when (keep-alive? response)
+ (keep-alive client))
+ (call-with-new-thread
+ (lambda ()
+ (set-thread-name "publish narinfo")
+ (let* ((narinfo
+ (with-store store
+ (narinfo-string store (utf8->string body)
+ #:nar-path nar-path
+ #:compressions compressions)))
+ (narinfo-bv (string->bytevector narinfo "UTF-8"))
+ (narinfo-length
+ (bytevector-length narinfo-bv))
+ (response (write-response
+ (with-content-length response
+ narinfo-length)
+ client))
+ (output (response-port response)))
+ (configure-socket client)
+ (put-bytevector output narinfo-bv)
+ (force-output output)
+ (unless (keep-alive? response)
+ (close-port output))
+ (values)))))
+ (%http-write server client response body))))
(_
(match (assoc-ref (response-headers response) 'x-raw-file)
((? string? file)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 65eb98e4b2..7faa92fd7d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -64,6 +64,7 @@
(device-module-aliases matching-modules)
#:use-module (gnu system linux-initrd)
#:use-module (gnu image)
+ #:use-module (gnu platform)
#:use-module (gnu system)
#:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
@@ -253,7 +254,7 @@ the ownership of '~a' may be incorrect!~%")
(install-bootloader local-eval bootloader bootcfg
#:target target)
(return
- (info (G_ "bootloader successfully installed on '~a'~%")
+ (info (G_ "bootloader successfully installed on~{ ~a~}~%")
(bootloader-configuration-targets bootloader))))))))
@@ -1212,13 +1213,11 @@ resulting from command-line parsing."
(base-image (if (operating-system? obj)
(os->image obj
#:type image-type)
- obj))
- (base-target (image-target base-image)))
+ obj)))
(image
(inherit (if label
(image-with-label base-image label)
base-image))
- (target (or base-target target))
(size image-size)
(volatile-root? volatile?))))
(os (image-operating-system image))
diff --git a/guix/self.scm b/guix/self.scm
index 79d93357a2..61ff423086 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -958,13 +958,23 @@ itself."
#:guile-for-build
guile-for-build))
+ (define *home-modules*
+ (scheme-node "guix-home"
+ `((gnu home)
+ (gnu home services)
+ ,@(scheme-modules* source "gnu/home/services"))
+ (list *core-package-modules* *package-modules*
+ *extra-modules* *core-modules* *system-modules*)
+ #:extensions dependencies
+ #:guile-for-build guile-for-build))
+
(define *cli-modules*
(scheme-node "guix-cli"
(append (scheme-modules* source "/guix/scripts")
`((gnu ci)))
(list *core-modules* *extra-modules*
*core-package-modules* *package-modules*
- *system-modules*)
+ *system-modules* *home-modules*)
#:extensions dependencies
#:guile-for-build guile-for-build))
@@ -1012,6 +1022,7 @@ itself."
*cli-modules*
*system-test-modules*
*system-modules*
+ *home-modules*
*package-modules*
*core-package-modules*
*extra-modules*
diff --git a/guix/swh.scm b/guix/swh.scm
index a62567dd58..5c41685a24 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -645,20 +645,29 @@ delete it when leaving the dynamic extent of this call."
(lambda ()
(false-if-exception (delete-file-recursively tmp-dir))))))
-(define* (swh-download-directory id output
- #:key (log-port (current-error-port)))
- "Download from Software Heritage the directory with the given ID, and
-unpack it to OUTPUT. Return #t on success and #f on failure"
+(define* (swh-download-archive swhid output
+ #:key
+ (archive-type 'flat)
+ (log-port (current-error-port)))
+ "Download from Software Heritage the directory or revision with the given
+SWID, in the ARCHIVE-TYPE format (one of 'flat or 'git-bare), and unpack it to
+OUTPUT. Return #t on success and #f on failure."
(call-with-temporary-directory
(lambda (directory)
- (match (vault-fetch id 'directory #:log-port log-port)
+ (match (vault-fetch swhid
+ #:archive-type archive-type
+ #:log-port log-port)
(#f
(format log-port
- "SWH: directory ~a could not be fetched from the vault~%"
- id)
+ "SWH: object ~a could not be fetched from the vault~%"
+ swhid)
#f)
((? port? input)
- (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
+ (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory
+ (match archive-type
+ ('flat "-xzvf") ;gzipped
+ ('git-bare "-xvf")) ;uncompressed
+ "-")))
(dump-port input tar)
(close-port input)
(let ((status (close-pipe tar)))
@@ -672,6 +681,14 @@ unpack it to OUTPUT. Return #t on success and #f on failure"
#:log (%make-void-port "w"))
#t))))))))
+(define* (swh-download-directory id output
+ #:key (log-port (current-error-port)))
+ "Download from Software Heritage the directory with the given ID, and
+unpack it to OUTPUT. Return #t on success and #f on failure."
+ (swh-download-archive (string-append "swh:1:dir:" id) output
+ #:archive-type 'flat
+ #:log-port log-port))
+
(define (commit-id? reference)
"Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
it is a tag name. This is based on a simple heuristic so use with care!"
@@ -679,8 +696,11 @@ it is a tag name. This is based on a simple heuristic so use with care!"
(string-every char-set:hex-digit reference)))
(define* (swh-download url reference output
- #:key (log-port (current-error-port)))
- "Download from Software Heritage a checkout of the Git tag or commit
+ #:key
+ (archive-type 'flat)
+ (log-port (current-error-port)))
+ "Download from Software Heritage a checkout (if ARCHIVE-TYPE is 'flat) or a
+full Git repository (if ARCHIVE-TYPE is 'git-bare) of the Git tag or commit
REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success
and #f on failure.
@@ -694,8 +714,16 @@ wait until it becomes available, which could take several minutes."
(format log-port "SWH: found revision ~a with directory at '~a'~%"
(revision-id revision)
(swh-url (revision-directory-url revision)))
- (swh-download-directory (revision-directory revision) output
- #:log-port log-port))
+ (swh-download-archive (match archive-type
+ ('flat
+ (string-append
+ "swh:1:dir:" (revision-directory revision)))
+ ('git-bare
+ (string-append
+ "swh:1:rev:" (revision-id revision))))
+ output
+ #:archive-type archive-type
+ #:log-port log-port))
(#f
(format log-port
"SWH: revision ~s originating from ~a could not be found~%"
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
index b8e5f7e643..69960284d9 100644
--- a/guix/tests/git.scm
+++ b/guix/tests/git.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -53,6 +54,7 @@ Return DIRECTORY on success."
(with-environment-variables
`(("GIT_CONFIG_NOSYSTEM" "1")
("GIT_ATTR_NOSYSTEM" "1")
+ ("GIT_CONFIG_GLOBAL" ,(string-append home "/.gitconfig"))
("HOME" ,home))
(apply invoke (git-command) "-C" directory
command args)))))
@@ -88,6 +90,9 @@ Return DIRECTORY on success."
((('tag name) rest ...)
(git "tag" name)
(loop rest))
+ ((('tag name text) rest ...)
+ (git "tag" "-m" text name)
+ (loop rest))
((('branch name) rest ...)
(git "branch" name)
(loop rest))