me/guix
Archived
1
0
Fork 0
Code Activity

Merge branch 'master' into staging

Browse source
This commit is contained in:
Brett Gilio 2019-12-13 07:57:51 -06:00
commit 94c7f70faa
No known key found for this signature in database
GPG key ID: 672243C4A03F0EEE
32 changed files with 824 additions and 207 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
doc/contributing.texi
View file

@ -962,11 +962,8 @@ the URL: it is not very useful and if the name changes, the URL will probably
be wrong. be wrong.
@item @item
See if Guix builds with Check if Guix builds (@pxref{Building from Git}) and address the
@example warnings, especially those about use of undefined symbols.
guix environment --pure guix -- make
@end example
and look for warnings, especially those about use of undefined symbols.
@item @item
Make sure your changes do not break Guix and simulate a @code{guix pull} with: Make sure your changes do not break Guix and simulate a @code{guix pull} with:

63
doc/guix.texi
View file

@ -39,7 +39,7 @@ Copyright @copyright{} 2016, 2017, 2018, 2019 Jan Nieuwenhuizen@*
Copyright @copyright{} 2016 Julien Lepiller@* Copyright @copyright{} 2016 Julien Lepiller@*
Copyright @copyright{} 2016 Alex ter Weele@* Copyright @copyright{} 2016 Alex ter Weele@*
Copyright @copyright{} 2016, 2017, 2018, 2019 Christopher Baines@* Copyright @copyright{} 2016, 2017, 2018, 2019 Christopher Baines@*
Copyright @copyright{} 2017, 2018 Clément Lassieur@* Copyright @copyright{} 2017, 2018, 2019 Clément Lassieur@*
Copyright @copyright{} 2017, 2018 Mathieu Othacehe@* Copyright @copyright{} 2017, 2018 Mathieu Othacehe@*
Copyright @copyright{} 2017 Federico Beffa@* Copyright @copyright{} 2017 Federico Beffa@*
Copyright @copyright{} 2017, 2018 Carlo Zancanaro@* Copyright @copyright{} 2017, 2018 Carlo Zancanaro@*
@ -4598,6 +4598,18 @@ unsafe.
The primary purpose of this operation is to facilitate inspection of The primary purpose of this operation is to facilitate inspection of
archive contents coming from possibly untrusted substitute servers. archive contents coming from possibly untrusted substitute servers.
@item --list
@itemx -t
Read a single-item archive as served by substitute servers
(@pxref{Substitutes}) and print the list of files it contains, as in
this example:
@example
$ wget -O - \
https://@value{SUBSTITUTE-SERVER}/nar/lzip/@dots{}-emacs-26.3 \
| lzip -d | guix archive -t
@end example
@end table @end table
@ -7457,6 +7469,7 @@ native package build:
(gexp->derivation "vi" (gexp->derivation "vi"
#~(begin #~(begin
(mkdir #$output) (mkdir #$output)
(mkdir (string-append #$output "/bin"))
(system* (string-append #+coreutils "/bin/ln") (system* (string-append #+coreutils "/bin/ln")
"-s" "-s"
(string-append #$emacs "/bin/emacs") (string-append #$emacs "/bin/emacs")
@ -10308,14 +10321,23 @@ updating list of substitutes from 'https://guix.example.org'... 100.0%
local hash: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q local hash: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-openssl-1.0.2d: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-openssl-1.0.2d: 0725l22r5jnzazaacncwsvp9kgf42266ayyp814v7djxs7nk963q
https://guix.example.org/nar/@dots{}-openssl-1.0.2d: 1zy4fmaaqcnjrzzajkdn3f5gmjk754b43qkq47llbyak9z0qjyim https://guix.example.org/nar/@dots{}-openssl-1.0.2d: 1zy4fmaaqcnjrzzajkdn3f5gmjk754b43qkq47llbyak9z0qjyim
differing files:
/lib/libcrypto.so.1.1
/lib/libssl.so.1.1
/gnu/store/@dots{}-git-2.5.0 contents differ: /gnu/store/@dots{}-git-2.5.0 contents differ:
local hash: 00p3bmryhjxrhpn2gxs2fy0a15lnip05l97205pgbk5ra395hyha local hash: 00p3bmryhjxrhpn2gxs2fy0a15lnip05l97205pgbk5ra395hyha
https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0: 069nb85bv4d4a6slrwjdy8v1cn4cwspm3kdbmyb81d6zckj3nq9f https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0: 069nb85bv4d4a6slrwjdy8v1cn4cwspm3kdbmyb81d6zckj3nq9f
https://guix.example.org/nar/@dots{}-git-2.5.0: 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73 https://guix.example.org/nar/@dots{}-git-2.5.0: 0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73
differing file:
/libexec/git-core/git-fsck
/gnu/store/@dots{}-pius-2.1.1 contents differ: /gnu/store/@dots{}-pius-2.1.1 contents differ:
local hash: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax local hash: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-pius-2.1.1: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-pius-2.1.1: 0k4v3m9z1zp8xzzizb7d8kjj72f9172xv078sq4wl73vnq9ig3ax
https://guix.example.org/nar/@dots{}-pius-2.1.1: 1cy25x1a4fzq5rk0pmvc8xhwyffnqz95h2bpvqsz2mpvlbccy0gs https://guix.example.org/nar/@dots{}-pius-2.1.1: 1cy25x1a4fzq5rk0pmvc8xhwyffnqz95h2bpvqsz2mpvlbccy0gs
differing file:
/share/man/man1/pius.1.gz
@dots{} @dots{}
@ -10344,8 +10366,20 @@ results, the inclusion of random numbers, and directory listings sorted
by inode number. See @uref{https://reproducible-builds.org/docs/}, for by inode number. See @uref{https://reproducible-builds.org/docs/}, for
more information. more information.
To find out what is wrong with this Git binary, we can do something along To find out what is wrong with this Git binary, the easiest approach is
these lines (@pxref{Invoking guix archive}): to run:
@example
guix challenge git \
--diff=diffoscope \
--substitute-urls="https://@value{SUBSTITUTE-SERVER} https://guix.example.org"
@end example
This automatically invokes @command{diffoscope}, which displays detailed
information about files that differ.
Alternately, we can do something along these lines (@pxref{Invoking guix
archive}):
@example @example
$ wget -q -O - https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0 \ $ wget -q -O - https://@value{SUBSTITUTE-SERVER}/nar/@dots{}-git-2.5.0 \
@ -10401,6 +10435,29 @@ The one option that matters is:
Consider @var{urls} the whitespace-separated list of substitute source Consider @var{urls} the whitespace-separated list of substitute source
URLs to compare to. URLs to compare to.
@item --diff=@var{mode}
Upon mismatches, show differences according to @var{mode}, one of:
@table @asis
@item @code{simple} (the default)
Show the list of files that differ.
@item @code{diffoscope}
@itemx @var{command}
Invoke @uref{https://diffoscope.org/, Diffoscope}, passing it
two directories whose contents do not match.
When @var{command} is an absolute file name, run @var{command} instead
of Diffoscope.
@item @code{none}
Do not show further details about the differences.
@end table
Thus, unless @code{--diff=none} is passed, @command{guix challenge}
downloads the store items from the given substitute servers so that it
can compare them.
@item --verbose @item --verbose
@itemx -v @itemx -v
Show details about matches (identical contents) in addition to Show details about matches (identical contents) in addition to

20
etc/news.scm
View file

@ -9,6 +9,26 @@
(channel-news (channel-news
(version 0) (version 0)
(entry (commit "828a39da68a9169ef1d9f9ff02a1c66b1bcbe884")
(title (en "New @option{--diff} option for @command{guix challenge}")
(de "Neue @option{--diff}-Option für @command{guix challenge}"))
(body (en "The @command{guix challenge} command, which compares
binaries provided by different substitute servers as well as those built
locally, has a new @option{--diff} option. With @option{--diff=simple} (the
default), @command{guix challenge} automatically downloads binaries and
reports the list of differing files; @option{--diff=diffoscope} instructs it
to pass them to @command{diffoscope}, which simplifies the comparison process.
Run @command{info \"(guix) Invoking guix challenge\"}, for more info.")
(de "Der Befehl @command{guix challenge}, mit dem Binärdateien
von unterschiedlichen Substitut-Servern oder lokale Erstellungen miteinander
verglichen werden können, hat eine neue Befehlszeilenoption @option{--diff}
bekommen. Bei @option{--diff=simple} (der Voreinstellung) lädt @command{guix
challenge} automatisch Binärdateien herunter und listet sich unterscheidende
Dateien auf; wird @option{--diff=diffoscope} angegeben, werden sie an
@command{diffoscope} geschickt, was deren Vergleich erleichtert. Führen Sie
@command{info \"(guix.de) Aufruf von guix challenge\"} aus, um nähere
Informationen zu erhalten.")))
(entry (commit "f675f8dec73d02e319e607559ed2316c299ae8c7") (entry (commit "f675f8dec73d02e319e607559ed2316c299ae8c7")
(title (en "New command @command{guix time-machine}") (title (en "New command @command{guix time-machine}")
(de "Neuer Befehl @command{guix time-machine}") (de "Neuer Befehl @command{guix time-machine}")

18
gnu/build/linux-boot.scm
View file

@ -358,10 +358,10 @@ the last argument of `mknod'."
(filter-map string->number (scandir "/proc"))))) (filter-map string->number (scandir "/proc")))))
(define* (mount-root-file-system root type (define* (mount-root-file-system root type
#:key volatile-root? options) #:key volatile-root? (flags 0) options)
"Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is
is true, mount ROOT read-only and make it an overlay with a writable tmpfs true, mount ROOT read-only and make it an overlay with a writable tmpfs using
using the kernel built-in overlayfs. OPTIONS indicates the options to use the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use
to mount ROOT." to mount ROOT."
(if volatile-root? (if volatile-root?
@ -384,7 +384,7 @@ to mount ROOT."
"lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work")) "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work"))
(begin (begin
(check-file-system root type) (check-file-system root type)
(mount root "/root" type 0 options))) (mount root "/root" type flags options)))
;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts. ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
(false-if-exception (false-if-exception
@ -474,6 +474,13 @@ upon error."
mounts) mounts)
"ext4")) "ext4"))
(define root-fs-flags
(mount-flags->bit-mask (or (any (lambda (fs)
(and (root-mount-point? fs)
(file-system-flags fs)))
mounts)
'())))
(define root-fs-options (define root-fs-options
(any (lambda (fs) (any (lambda (fs)
(and (root-mount-point? fs) (and (root-mount-point? fs)
@ -533,6 +540,7 @@ upon error."
(mount-root-file-system (canonicalize-device-spec root) (mount-root-file-system (canonicalize-device-spec root)
root-fs-type root-fs-type
#:volatile-root? volatile-root? #:volatile-root? volatile-root?
#:flags root-fs-flags
#:options root-fs-options)) #:options root-fs-options))
(mount "none" "/root" "tmpfs")) (mount "none" "/root" "tmpfs"))

1
gnu/local.mk
View file

@ -1012,6 +1012,7 @@ dist_patch_DATA = \
%D%/packages/patches/java-xerces-xjavac_taskdef.patch \ %D%/packages/patches/java-xerces-xjavac_taskdef.patch \
%D%/packages/patches/jbig2dec-ignore-testtest.patch \ %D%/packages/patches/jbig2dec-ignore-testtest.patch \
%D%/packages/patches/kdbusaddons-kinit-file-name.patch \ %D%/packages/patches/kdbusaddons-kinit-file-name.patch \
%D%/packages/patches/libnftnl-dont-check-NFTNL_FLOWTABLE_SIZE.patch \
%D%/packages/patches/libvirt-create-machine-cgroup.patch \ %D%/packages/patches/libvirt-create-machine-cgroup.patch \
%D%/packages/patches/libziparchive-add-includes.patch \ %D%/packages/patches/libziparchive-add-includes.patch \
%D%/packages/patches/localed-xorg-keyboard.patch \ %D%/packages/patches/localed-xorg-keyboard.patch \

6
gnu/packages/benchmark.scm
View file

@ -43,14 +43,14 @@
(define-public fio (define-public fio
(package (package
(name "fio") (name "fio")
(version "3.14") (version "3.16")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "http://brick.kernel.dk/snaps/" (uri (string-append "https://brick.kernel.dk/snaps/"
"fio-" version ".tar.bz2")) "fio-" version ".tar.bz2"))
(sha256 (sha256
(base32 (base32
"047y53nyhnmnxcrsfbsf0gcpxw7bli3n19ycscpxy9974j0fck0v")))) "17hi6cd4wahghh7kgvxcvmrhcqlmqag3a07id90hhzwd3zhvdxbp"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
'(#:test-target "test" '(#:test-target "test"

4
gnu/packages/calendar.scm
View file

@ -155,7 +155,7 @@ able to synchronize with CalDAV servers through vdirsyncer.")
(define-public remind (define-public remind
(package (package
(name "remind") (name "remind")
(version "3.1.16") (version "3.1.17")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
@ -166,7 +166,7 @@ able to synchronize with CalDAV servers through vdirsyncer.")
".") ".")
".tar.gz")) ".tar.gz"))
(sha256 (sha256
(base32 "14yavwqmimba8rdpwx3wlav9sfb0v5rcd1iyzqrs08wx07a9pdzf")))) (base32 "0lgyc2j69aqqk4knywr8inz4fsnni0zq54dgqh7p4s6kzybc2mf9"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
'(#:tests? #f)) ; no "check" target '(#:tests? #f)) ; no "check" target

4
gnu/packages/cdrom.scm
View file

@ -134,14 +134,14 @@ extraction from CDs.")
(define-public libcdio-paranoia (define-public libcdio-paranoia
(package (package
(name "libcdio-paranoia") (name "libcdio-paranoia")
(version "10.2+2.0.0") (version "10.2+2.0.1")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "mirror://gnu/libcdio/libcdio-paranoia-" (uri (string-append "mirror://gnu/libcdio/libcdio-paranoia-"
version ".tar.bz2")) version ".tar.bz2"))
(sha256 (sha256
(base32 (base32
"1h8k8z9r75h3p697f77z9j1blwb6gf2d5rik6z2q6420my6c2ra5")))) "12hfnrq7amv9qjzc92cr265m7kh0a1hpasck8cxx1gygbhqczc9k"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs `(("pkg-config" ,pkg-config))) (native-inputs `(("pkg-config" ,pkg-config)))
(propagated-inputs `(("libcdio" ,libcdio))) (propagated-inputs `(("libcdio" ,libcdio)))

25
gnu/packages/coq.scm
View file

@ -58,6 +58,7 @@
(variable "COQPATH") (variable "COQPATH")
(files (list "lib/coq/user-contrib"))))) (files (list "lib/coq/user-contrib")))))
(build-system ocaml-build-system) (build-system ocaml-build-system)
(outputs '("out" "ide"))
(inputs (inputs
`(("lablgtk" ,lablgtk) `(("lablgtk" ,lablgtk)
("python" ,python-2) ("python" ,python-2)
@ -72,6 +73,13 @@
(lambda _ (lambda _
(for-each make-file-writable (find-files ".")) (for-each make-file-writable (find-files "."))
#t)) #t))
(add-after 'unpack 'remove-lablgtk-references
(lambda _
;; This is not used anywhere, but creates a reference to lablgtk in
;; every binary
(substitute* '("config/coq_config.mli" "configure.ml")
((".*coqideincl.*") ""))
#t))
(replace 'configure (replace 'configure
(lambda* (#:key outputs #:allow-other-keys) (lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out")) (let* ((out (assoc-ref outputs "out"))
@ -88,6 +96,23 @@
"-j" (number->string (parallel-job-count)) "-j" (number->string (parallel-job-count))
"world"))) "world")))
(delete 'check) (delete 'check)
(add-after 'install 'remove-duplicate
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin")))
;; These are exact copies of the version without the .opt suffix.
;; Remove them to save 35 MiB in the result
(delete-file (string-append bin "/coqtop.opt"))
(delete-file (string-append bin "/coqidetop.opt")))
#t))
(add-after 'install 'install-ide
(lambda* (#:key outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(ide (assoc-ref outputs "ide")))
(mkdir-p (string-append ide "/bin"))
(rename-file (string-append out "/bin/coqide")
(string-append ide "/bin/coqide")))
#t))
(add-after 'install 'check (add-after 'install 'check
(lambda _ (lambda _
(with-directory-excursion "test-suite" (with-directory-excursion "test-suite"

41
gnu/packages/emacs-xyz.scm
View file

@ -19816,6 +19816,33 @@ Emacs that integrate with major modes like Org-mode.")
(home-page "https://github.com/hlissner/emacs-doom-themes") (home-page "https://github.com/hlissner/emacs-doom-themes")
(license license:expat))) (license license:expat)))
(define-public emacs-modus-themes
(package
(name "emacs-modus-themes")
(version "0.1.0")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://gitlab.com/protesilaos/modus-themes.git")
(commit version)))
(file-name (git-file-name name version))
(sha256
(base32
"15g63675c5df2p0kk2sqj2c8qriyh69lcbggknqlaxapr13giz4x"))))
(build-system emacs-build-system)
(home-page "https://gitlab.com/protesilaos/modus-themes")
(synopsis "Emacs themes designed for colour-contrast accessibility")
(description
"This is a set of accessible themes for GNU Emacs. The contrast ratio
between foreground and background values should always be >= 7:1, which
conforms with the WCAG AAA accessibility standard.
The Modus themes project consists of two standalone items, one where dark text
is cast on a light backdrop (Modus Operandi) and another where light text is
displayed against a dark background (Modus Vivendi).")
(license license:gpl3+)))
(define-public emacs-elixir-mode (define-public emacs-elixir-mode
(package (package
(name "emacs-elixir-mode") (name "emacs-elixir-mode")
@ -20046,9 +20073,9 @@ fish-completion. It can be used in both Eshell and M-x shell.")
(license license:gpl3+)))) (license license:gpl3+))))
(define-public emacs-telega (define-public emacs-telega
(let ((commit "56aef884921d99e5170d5425dbe0fce645620511") (let ((commit "6184e76990db395bea02f7b5d3169e746111e1ad")
(revision "2") (revision "2")
(version "0.4.4")) (version "0.5.2"))
(package (package
(name "emacs-telega") (name "emacs-telega")
(version (git-version version revision commit)) (version (git-version version revision commit))
@ -20060,7 +20087,7 @@ fish-completion. It can be used in both Eshell and M-x shell.")
(commit commit))) (commit commit)))
(sha256 (sha256
(base32 (base32
"0a8k3j20nz4xwswg9qp9xpaakk3q3ibiz8mkryk92zmrdmaah5mi")) "1kfmmfc9dv3r2wxm1njflgas51qm0j8sj7yr7vfvwaz5sz7p121b"))
(file-name (git-file-name name version)))) (file-name (git-file-name name version))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
@ -20142,15 +20169,17 @@ fish-completion. It can be used in both Eshell and M-x shell.")
(add-after 'emacs-build 'emacs-make-autoloads (add-after 'emacs-build 'emacs-make-autoloads
(assoc-ref emacs:%standard-phases 'make-autoloads))))) (assoc-ref emacs:%standard-phases 'make-autoloads)))))
(propagated-inputs (propagated-inputs
`(("emacs-visual-fill-column" ,emacs-visual-fill-column))) `(("emacs-visual-fill-column" ,emacs-visual-fill-column)
("ffmpeg" ,ffmpeg) ; mp4/gif support.
("libwebp" ,libwebp))) ; sticker support.
(native-inputs (native-inputs
`(("tdlib" ,tdlib) `(("tdlib" ,tdlib)
("emacs" ,emacs-minimal) ("emacs" ,emacs-minimal)
("python" ,python))) ("python" ,python)))
(synopsis "GNU Emacs client for the Telegram messenger") (synopsis "GNU Emacs client for the Telegram messenger")
(description (description
"Telega is full-featured, unofficial client for the Telegram messaging "Telega is a full-featured, unofficial GNU Emacs-based client for the
platform for GNU Emacs.") Telegram messaging platform.")
(home-page "https://github.com/zevlg/telega.el") (home-page "https://github.com/zevlg/telega.el")
(license license:gpl3+)))) (license license:gpl3+))))

5
gnu/packages/imagemagick.scm
View file

@ -170,7 +170,7 @@ script.")
(define-public graphicsmagick (define-public graphicsmagick
(package (package
(name "graphicsmagick") (name "graphicsmagick")
(version "1.3.32") (version "1.3.33")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
@ -182,8 +182,7 @@ script.")
"GraphicsMagick/" (version-major+minor version) "GraphicsMagick/" (version-major+minor version)
"/GraphicsMagick-" version ".tar.xz"))) "/GraphicsMagick-" version ".tar.xz")))
(sha256 (sha256
(base32 (base32 "0y67dl6xbk1pxndppa93hhlq9i6bpcjw39gb4i8hnn1klqqb630k"))))
"1qclp9i31idpcbbqswmnq2q11lmv0a7cvdb1y72xcky8sshaahmq"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
`(#:configure-flags `(#:configure-flags

5
gnu/packages/ipfs.scm
View file

@ -104,7 +104,7 @@ that are shared between @command{go-ipfs/commands} and its rewrite
(define-public gx (define-public gx
(package (package
(name "gx") (name "gx")
(version "0.14.1") (version "0.14.2")
(source (source
(origin (origin
(method git-fetch) (method git-fetch)
@ -113,8 +113,7 @@ that are shared between @command{go-ipfs/commands} and its rewrite
(commit (string-append "v" version)))) (commit (string-append "v" version))))
(file-name (git-file-name name version)) (file-name (git-file-name name version))
(sha256 (sha256
(base32 (base32 "048bx6khzcwxnvz3lf7kgp6fkg8mxqcqchxh0jxm9fg2iwizsi0k"))))
"0pfx2p59xdbmqzfbgaf8xvlnzh8m05hkg596glq5kvl8ib65i4ha"))))
(build-system go-build-system) (build-system go-build-system)
(arguments (arguments
'(#:import-path "github.com/whyrusleeping/gx")) '(#:import-path "github.com/whyrusleeping/gx"))

4
gnu/packages/libreoffice.scm
View file

@ -174,14 +174,14 @@ spreadsheets and presentations.")
(define-public libwpd (define-public libwpd
(package (package
(name "libwpd") (name "libwpd")
(version "0.10.2") (version "0.10.3")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (string-append "mirror://sourceforge/libwpd/libwpd/" (uri (string-append "mirror://sourceforge/libwpd/libwpd/"
"libwpd-" version "/libwpd-" version ".tar.xz")) "libwpd-" version "/libwpd-" version ".tar.xz"))
(sha256 (base32 (sha256 (base32
"0436gnidx45a9vx114hhh216jrh57mqb9zyssyjfadagmyz6hgrj")))) "02fx8bngslcj7i5g1gx2kiign4vp09wrmp5wpvix9igxcavb0r94"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
`(#:configure-flags '("--disable-werror"))) `(#:configure-flags '("--disable-werror")))

23
gnu/packages/linux.scm
View file

@ -1678,7 +1678,7 @@ external rate conversion.")
(define-public iptables (define-public iptables
(package (package
(name "iptables") (name "iptables")
(version "1.6.2") (version "1.8.4")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append (uri (string-append
@ -1686,7 +1686,7 @@ external rate conversion.")
version ".tar.bz2")) version ".tar.bz2"))
(sha256 (sha256
(base32 (base32
"0crp0lvh5m2f15pr8cw97h8yb8zjj10x95zj06j46cr68vx2vl2m")))) "0z0mgs1ghvn3slc868mgbf2g26njgrzcy5ggyb5w4i55j1a3lflr"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs (native-inputs
`(("pkg-config" ,pkg-config) `(("pkg-config" ,pkg-config)
@ -5233,14 +5233,16 @@ re-use code and to avoid re-inventing the wheel.")
(define-public libnftnl (define-public libnftnl
(package (package
(name "libnftnl") (name "libnftnl")
(version "1.1.4") (version "1.1.5")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (string-append "mirror://netfilter.org/libnftnl/" (uri (string-append "mirror://netfilter.org/libnftnl/"
"libnftnl-" version ".tar.bz2")) "libnftnl-" version ".tar.bz2"))
(sha256 (sha256
(base32 "087dfc2n4saf2k68hyi4byvgz5grwpw5kfjvmkpn3wmd8y1riiy8")))) (base32 "1wqlxf76bkqf3qhka9sw32qhb2ni20q1k6rn3iril2kw482lvpk6"))
(patches
(search-patches "libnftnl-dont-check-NFTNL_FLOWTABLE_SIZE.patch"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs (native-inputs
`(("pkg-config" ,pkg-config))) `(("pkg-config" ,pkg-config)))
@ -5257,15 +5259,16 @@ used by nftables.")
(define-public nftables (define-public nftables
(package (package
(name "nftables") (name "nftables")
(version "0.9.2") (version "0.9.3")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (string-append "http://www.nftables.org/projects/nftables" (uri (list (string-append "mirror://netfilter.org/nftables/nftables-"
"/files/nftables-" version ".tar.bz2")) version ".tar.bz2")
(string-append "https://www.nftables.org/projects/nftables"
"/files/nftables-" version ".tar.bz2")))
(sha256 (sha256
(base32 (base32 "0y6vbqp6x8w165q65h4n9sba1406gaz0d4744gqszbm7w9f92swm"))))
"1x8kalbggjq44j4916i6vyv1rb20dlh1dcsf9xvzqsry2j063djw"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments `(#:configure-flags (arguments `(#:configure-flags
'("--disable-man-doc"))) ; FIXME: Needs docbook2x. '("--disable-man-doc"))) ; FIXME: Needs docbook2x.
@ -5276,7 +5279,7 @@ used by nftables.")
("libnftnl" ,libnftnl) ("libnftnl" ,libnftnl)
("readline" ,readline))) ("readline" ,readline)))
(native-inputs `(("pkg-config" ,pkg-config))) (native-inputs `(("pkg-config" ,pkg-config)))
(home-page "http://www.nftables.org") (home-page "https://www.nftables.org")
(synopsis "Userspace utility for Linux packet filtering") (synopsis "Userspace utility for Linux packet filtering")
(description "nftables is the project that aims to replace the existing (description "nftables is the project that aims to replace the existing
{ip,ip6,arp,eb}tables framework. Basically, this project provides a new packet {ip,ip6,arp,eb}tables framework. Basically, this project provides a new packet

21
gnu/packages/mail.scm
View file

@ -555,15 +555,14 @@ Extension (MIME).")
(define-public bogofilter (define-public bogofilter
(package (package
(name "bogofilter") (name "bogofilter")
(version "1.2.4") (version "1.2.5")
(source (origin (source
(method url-fetch) (origin
(uri (string-append "mirror://sourceforge/bogofilter/bogofilter-" (method url-fetch)
version "/bogofilter-" (uri (string-append "mirror://sourceforge/bogofilter/bogofilter-stable/"
version ".tar.bz2")) "bogofilter-" version ".tar.xz"))
(sha256 (sha256
(base32 (base32 "1sl9xrnnlk2sn8gmibhn8li09vnansjbxb9l1182qmgz7cvs2j1j"))))
"1d56n2m9inm8gnzm88aa27xl2a7sp7aff3484vmflpqkinjqf0p1"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
'(#:phases '(#:phases
@ -576,14 +575,14 @@ Extension (MIME).")
#t))))) #t)))))
(native-inputs `(("flex" ,flex))) (native-inputs `(("flex" ,flex)))
(inputs `(("bdb" ,bdb))) (inputs `(("bdb" ,bdb)))
(home-page "http://bogofilter.sourceforge.net/") (home-page "https://bogofilter.sourceforge.io/")
(synopsis "Mail classifier based on a Bayesian filter") (synopsis "Mail classifier based on a Bayesian filter")
(description (description
"Bogofilter is a mail filter that classifies mail as spam or ham "Bogofilter is a mail filter that classifies mail as spam or ham
(non-spam) by a statistical analysis of the message's header and (non-spam) by a statistical analysis of the message's header and
content (body). The program is able to learn from the user's classifications content (body). The program is able to learn from the user's classifications
and corrections. It is based on a Bayesian filter.") and corrections. It is based on a Bayesian filter.")
(license gpl2))) (license gpl3+)))
(define-public offlineimap (define-public offlineimap
(package (package

2
gnu/packages/music.scm
View file

@ -3924,7 +3924,7 @@ sample library.")
(string-map (lambda (c) (string-map (lambda (c)
(if (char=? c #\.) (if (char=? c #\.)
#\_ c)) version))))) #\_ c)) version)))))
(file-name (string-append name "-" version "-checkout")) (file-name (git-file-name name version))
(sha256 (sha256
(base32 (base32
"1nninz8qyqlxxjdnrm79y3gr3056pga9l2fsqh674jd3cjvafya3")))) "1nninz8qyqlxxjdnrm79y3gr3056pga9l2fsqh674jd3cjvafya3"))))

47
gnu/packages/patches/libnftnl-dont-check-NFTNL_FLOWTABLE_SIZE.patch Normal file
View file

@ -0,0 +1,47 @@
From: Tobias Geerinckx-Rice <me@tobias.gr>
Date: Tue, 10 Dec 2019 16:20:40 +0100
Subject: gnu: libnftnl: Don't check NFTNL_FLOWTABLE_SIZE.
Taken verbatim from the upstream commit[0] directly following the 1.1.5
release.
[0]: https://git.netfilter.org/libnftnl/commit/?id=b2388765e0c4405442faa13845419f6a35d0134c
From b2388765e0c4405442faa13845419f6a35d0134c Mon Sep 17 00:00:00 2001
From: Phil Sutter <phil@nwl.cc>
Date: Mon, 2 Dec 2019 18:29:56 +0100
Subject: tests: flowtable: Don't check NFTNL_FLOWTABLE_SIZE
Marshalling code around that attribute has been dropped by commit
d1c4b98c733a5 ("flowtable: remove NFTA_FLOWTABLE_SIZE") so it's value is
lost during the test.
Assuming that NFTNL_FLOWTABLE_SIZE will receive kernel support at a
later point, leave the test code in place but just comment it out.
Fixes: d1c4b98c733a5 ("flowtable: remove NFTA_FLOWTABLE_SIZE")
Signed-off-by: Phil Sutter <phil@nwl.cc>
Acked-by: Pablo Neira Ayuso <pablo@netfilter.org>
---
tests/nft-flowtable-test.c | 2 ++
1 file changed, 2 insertions(+)
diff --git a/tests/nft-flowtable-test.c b/tests/nft-flowtable-test.c
index 3edb00d..8ab8d4c 100644
--- a/tests/nft-flowtable-test.c
+++ b/tests/nft-flowtable-test.c
@@ -33,9 +33,11 @@ static void cmp_nftnl_flowtable(struct nftnl_flowtable *a, struct nftnl_flowtabl
if (nftnl_flowtable_get_u32(a, NFTNL_FLOWTABLE_USE) !=
nftnl_flowtable_get_u32(b, NFTNL_FLOWTABLE_USE))
print_err("Flowtable use mismatches");
+#if 0
if (nftnl_flowtable_get_u32(a, NFTNL_FLOWTABLE_SIZE) !=
nftnl_flowtable_get_u32(b, NFTNL_FLOWTABLE_SIZE))
print_err("Flowtable size mismatches");
+#endif
if (nftnl_flowtable_get_u32(a, NFTNL_FLOWTABLE_FLAGS) !=
nftnl_flowtable_get_u32(b, NFTNL_FLOWTABLE_FLAGS))
print_err("Flowtable flags mismatches");
--
cgit v1.2.1

27
gnu/packages/python-xyz.scm
View file

@ -14327,24 +14327,15 @@ such as figshare or Zenodo.")
(define-public python-semver (define-public python-semver
(package (package
(name "python-semver") (name "python-semver")
(version "2.7.9") (version "2.9.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "semver" version)) (uri (pypi-uri "semver" version))
(sha256 (sha256
(base32 (base32
"0hhgqppchv59rqj0yzi1prdg2nfsywqmjsqy2rycyxm0hvxmbyqz")))) "183kg1rhzz3hqizvphkd8hlbf1zxfx8737zhfkmqzxi71jmdw7pd"))))
(build-system python-build-system) (build-system python-build-system)
(arguments
`(#:phases
(modify-phases %standard-phases
(add-after 'unpack 'patch-test-requirements
(lambda _
(substitute* "setup.py"
;; Our Python is new enough.
(("'virtualenv<14\\.0\\.0'") "'virtualenv'"))
#t)))))
(native-inputs (native-inputs
`(("python-tox" ,python-tox) `(("python-tox" ,python-tox)
("python-virtualenv" ,python-virtualenv))) ("python-virtualenv" ,python-virtualenv)))
@ -14564,14 +14555,14 @@ user's @file{~/Trash} directory.")
(define-public python-yapf (define-public python-yapf
(package (package
(name "python-yapf") (name "python-yapf")
(version "0.24.0") (version "0.29.0")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "yapf" version)) (uri (pypi-uri "yapf" version))
(sha256 (sha256
(base32 (base32
"0anwby0ydmyzcsgjc5dn1ryddwvii4dq61vck447q0n96npnzfyf")))) "1pj3xzblmbssshi889b6n9hwqbjpabw6j0fimlng2sshd3226bki"))))
(build-system python-build-system) (build-system python-build-system)
(home-page "https://github.com/google/yapf") (home-page "https://github.com/google/yapf")
(synopsis "Formatter for Python code") (synopsis "Formatter for Python code")

10
gnu/packages/terminals.scm
View file

@ -16,6 +16,7 @@
;;; Copyright © 2018, 2019 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2018, 2019 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2019 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2019 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2019 Brett Gilio <brettg@posteo.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -828,20 +829,21 @@ of VT100 terminal.")
(define-public python-blessings (define-public python-blessings
(package (package
(name "python-blessings") (name "python-blessings")
(version "1.6.1") (version "1.7")
(source (source
(origin (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "blessings" version)) (uri (pypi-uri "blessings" version))
(sha256 (sha256
(base32 (base32
"1smngy65p8mi62lgm04icasx22v976szhs2aq95y2ljmi1srb4bl")))) "0z8mgkbmisxs10rz88qg46l1c9a8n08k8cy2iassal2zh16qbrcq"))))
(build-system python-build-system) (build-system python-build-system)
(arguments (arguments
;; TODO: For py3, 2to2 is used to convert the code, but test-suite fails ;; FIXME: Test suite is unable to detect TTY conditions.
`(#:tests? #f)) `(#:tests? #f))
(native-inputs (native-inputs
`(("python-nose" ,python-nose))) `(("python-nose" ,python-nose)
("python-six" ,python-six)))
(home-page "https://github.com/erikrose/blessings") (home-page "https://github.com/erikrose/blessings")
(synopsis "Python module to manage terminal color, styling, and (synopsis "Python module to manage terminal color, styling, and
positioning") positioning")

6
gnu/packages/tls.scm
View file

@ -553,13 +553,13 @@ netcat implementation that supports TLS.")
(package (package
(name "python-acme") (name "python-acme")
;; Remember to update the hash of certbot when updating python-acme. ;; Remember to update the hash of certbot when updating python-acme.
(version "0.40.1") (version "1.0.0")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (pypi-uri "acme" version)) (uri (pypi-uri "acme" version))
(sha256 (sha256
(base32 (base32
"1z2zibs9lyxi5gxw9bny1127bjliwsp476kai1wnnnwd8238dgrk")))) "1hl62dnh8zsipa5azzpy5kwgjgb5vflinhna1fsn7rcchhpz223a"))))
(build-system python-build-system) (build-system python-build-system)
(arguments (arguments
`(#:phases `(#:phases
@ -610,7 +610,7 @@ netcat implementation that supports TLS.")
(uri (pypi-uri "certbot" version)) (uri (pypi-uri "certbot" version))
(sha256 (sha256
(base32 (base32
"1l8h7ggq75h59246mmzigmjr5jvzi29hihrnz9aiqh6g8hq1pj4d")))) "0aih7sir5byy8ah9lrgzwcaga7hjw98qj8bb1pxzzzqrvcqjvf46"))))
(build-system python-build-system) (build-system python-build-system)
(arguments (arguments
`(,@(substitute-keyword-arguments (package-arguments python-acme) `(,@(substitute-keyword-arguments (package-arguments python-acme)

4
gnu/packages/vpn.scm
View file

@ -456,14 +456,14 @@ The peer-to-peer VPN implements a Layer 2 (Ethernet) network between the peers
(define-public wireguard (define-public wireguard
(package (package
(name "wireguard") (name "wireguard")
(version "0.0.20191127") (version "0.0.20191212")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://git.zx2c4.com/WireGuard/snapshot/" (uri (string-append "https://git.zx2c4.com/WireGuard/snapshot/"
"WireGuard-" version ".tar.xz")) "WireGuard-" version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"01ixdhbvx5yiq07msd60f98685wdksss4pfhdn1d8r25z2k80kkx")))) "0wdhl7i4zkb7yf0jj03ig2ks7bsfz9if8x9dy6r2523s1ww1imxh"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(outputs '("out" ; The WireGuard userspace tools (outputs '("out" ; The WireGuard userspace tools
"kernel-patch")) ; A patch to build Linux with WireGuard support "kernel-patch")) ; A patch to build Linux with WireGuard support

7
gnu/packages/web.scm
View file

@ -4194,8 +4194,8 @@ CDF, Atom 0.3, and Atom 1.0 feeds.")
(package-with-python2 python-feedparser)) (package-with-python2 python-feedparser))
(define-public guix-data-service (define-public guix-data-service
(let ((commit "af1324855e1ecaf9b1dd7afcc714d09aaa38f081") (let ((commit "156b7eea7e7d538e332d8cfcf482c5ebec0a25c0")
(revision "6")) (revision "7"))
(package (package
(name "guix-data-service") (name "guix-data-service")
(version (string-append "0.0.1-" revision "." (string-take commit 7))) (version (string-append "0.0.1-" revision "." (string-take commit 7)))
@ -4207,7 +4207,7 @@ CDF, Atom 0.3, and Atom 1.0 feeds.")
(file-name (git-file-name name version)) (file-name (git-file-name name version))
(sha256 (sha256
(base32 (base32
"1qxs1sbyx894njw4f898wzc5shjj85h9kgz95p8mq1acmazhlhkv")))) "1cg7jzk7pabfp3mgnkpycasv7fs522xp3nqdvna1y76aif3pd3zh"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
'(#:modules ((guix build utils) '(#:modules ((guix build utils)
@ -4251,6 +4251,7 @@ CDF, Atom 0.3, and Atom 1.0 feeds.")
"guix-data-service-process-branch-updated-mbox" "guix-data-service-process-branch-updated-mbox"
"guix-data-service-process-job" "guix-data-service-process-job"
"guix-data-service-process-jobs" "guix-data-service-process-jobs"
"guix-data-service-manage-build-servers"
"guix-data-service-query-build-servers")) "guix-data-service-query-build-servers"))
#t))) #t)))
(delete 'strip)))) ; As the .go files aren't compatible (delete 'strip)))) ; As the .go files aren't compatible

14
guix/build/emacs-build-system.scm
View file

@ -76,8 +76,18 @@ archive, a directory, or an Emacs Lisp file."
(define* (add-source-to-load-path #:key dummy #:allow-other-keys) (define* (add-source-to-load-path #:key dummy #:allow-other-keys)
"Augment the EMACSLOADPATH environment variable with the source directory." "Augment the EMACSLOADPATH environment variable with the source directory."
(let* ((source-directory (getcwd)) (let* ((source-directory (getcwd))
(emacs-load-path-value (string-append source-directory ":" (emacs-load-path (string-split (getenv "EMACSLOADPATH") #\:))
(getenv "EMACSLOADPATH")))) ;; XXX: Make sure the Emacs core libraries appear at the end of
;; EMACSLOADPATH, to avoid shadowing any other libraries depended
;; upon.
(emacs-load-path-non-core (filter (cut string-contains <>
"/share/emacs/site-lisp")
emacs-load-path))
(emacs-load-path-value (string-append
(string-join (cons source-directory
emacs-load-path-non-core)
":")
":")))
(setenv "EMACSLOADPATH" emacs-load-path-value) (setenv "EMACSLOADPATH" emacs-load-path-value)
(format #t "source directory ~s prepended to the `EMACSLOADPATH' \ (format #t "source directory ~s prepended to the `EMACSLOADPATH' \
environment variable\n" source-directory))) environment variable\n" source-directory)))

31
guix/progress.scm
View file

@ -40,6 +40,7 @@
progress-reporter/file progress-reporter/file
progress-reporter/bar progress-reporter/bar
progress-reporter/trace progress-reporter/trace
progress-report-port
display-download-progress display-download-progress
erase-current-line erase-current-line
@ -342,3 +343,33 @@ should be a <progress-reporter> object."
(put-bytevector out buffer 0 bytes) (put-bytevector out buffer 0 bytes)
(report total) (report total)
(loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
(define (progress-report-port reporter port)
"Return a port that continuously reports the bytes read from PORT using
REPORTER, which should be a <progress-reporter> object."
(match reporter
(($ <progress-reporter> start report stop)
(let* ((total 0)
(read! (lambda (bv start count)
(let ((n (match (get-bytevector-n! port bv start count)
((? eof-object?) 0)
(x x))))
(set! total (+ total n))
(report total)
n))))
(start)
(make-custom-binary-input-port "progress-port-proc"
read! #f #f
(lambda ()
;; XXX: Kludge! When used through
;; 'decompressed-port', this port ends
;; up being closed twice: once in a
;; child process early on, and at the
;; end in the parent process. Ignore
;; the early close so we don't output
;; a spurious "download-succeeded"
;; trace.
(unless (zero? total)
(stop))
(close-port port)))))))

45
guix/scripts/archive.scm
View file

@ -21,7 +21,8 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix combinators) #:use-module (guix combinators)
#:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module ((guix serialization) #:select (restore-file)) #:use-module ((guix serialization)
#:select (fold-archive restore-file))
#:use-module (guix store) #:use-module (guix store)
#:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix grafts) #:use-module (guix grafts)
@ -43,6 +44,7 @@
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (ice-9 binary-ports) #:use-module (ice-9 binary-ports)
#:use-module (rnrs bytevectors)
#:export (guix-archive #:export (guix-archive
options->derivations+files)) options->derivations+files))
@ -76,6 +78,8 @@ Export/import one or more packages from/to the store.\n"))
--missing print the files from stdin that are missing")) --missing print the files from stdin that are missing"))
(display (G_ " (display (G_ "
-x, --extract=DIR extract the archive on stdin to DIR")) -x, --extract=DIR extract the archive on stdin to DIR"))
(display (G_ "
-t, --list list the files in the archive on stdin"))
(newline) (newline)
(display (G_ " (display (G_ "
--generate-key[=PARAMETERS] --generate-key[=PARAMETERS]
@ -137,6 +141,9 @@ Export/import one or more packages from/to the store.\n"))
(option '("extract" #\x) #t #f (option '("extract" #\x) #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'extract arg result))) (alist-cons 'extract arg result)))
(option '("list" #\t) #f #f
(lambda (opt name arg result)
(alist-cons 'list #t result)))
(option '("generate-key") #f #t (option '("generate-key") #f #t
(lambda (opt name arg result) (lambda (opt name arg result)
(catch 'gcry-error (catch 'gcry-error
@ -319,6 +326,40 @@ the input port."
(with-atomic-file-output %acl-file (with-atomic-file-output %acl-file
(cut write-acl acl <>))))) (cut write-acl acl <>)))))
(define (list-contents port)
"Read a nar from PORT and print the list of files it contains to the current
output port."
(define (consume-input port size)
(let ((bv (make-bytevector 32768)))
(let loop ((total size))
(unless (zero? total)
(let ((n (get-bytevector-n! port bv 0
(min total (bytevector-length bv)))))
(loop (- total n)))))))
(fold-archive (lambda (file type content result)
(match type
('directory
(format #t "D ~a~%" file))
('symlink
(format #t "S ~a -> ~a~%" file content))
((or 'regular 'executable)
(match content
((input . size)
(format #t "~a ~60a ~10h B~%"
(if (eq? type 'executable)
"x" "r")
file size)
(consume-input input size))))))
#t
port
""))
;;;
;;; Entry point.
;;;
(define (guix-archive . args) (define (guix-archive . args)
(define (lines port) (define (lines port)
;; Return lines read from PORT. ;; Return lines read from PORT.
@ -353,6 +394,8 @@ the input port."
(missing (remove (cut valid-path? store <>) (missing (remove (cut valid-path? store <>)
files))) files)))
(format #t "~{~a~%~}" missing))) (format #t "~{~a~%~}" missing)))
((assoc-ref opts 'list)
(list-contents (current-input-port)))
((assoc-ref opts 'extract) ((assoc-ref opts 'extract)
=> =>
(lambda (target) (lambda (target)

220
guix/scripts/challenge.scm
View file

@ -25,17 +25,23 @@
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix progress)
#:use-module (guix serialization) #:use-module (guix serialization)
#:use-module (guix scripts substitute) #:use-module (guix scripts substitute)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:autoload (guix http-client) (http-fetch)
#:use-module ((guix build syscalls) #:select (terminal-columns))
#:use-module (gcrypt hash)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 ftw)
#:use-module (web uri) #:use-module (web uri)
#:export (compare-contents #:export (compare-contents
@ -49,6 +55,9 @@
comparison-report-mismatch? comparison-report-mismatch?
comparison-report-inconclusive? comparison-report-inconclusive?
differing-files
call-with-mismatches
guix-challenge)) guix-challenge))
;;; Commentary: ;;; Commentary:
@ -179,20 +188,192 @@ taken since we do not import the archives."
items items
local)))) local))))
;;;
;;; Reporting.
;;;
(define dump-port* ;FIXME: deduplicate
(@@ (guix serialization) dump))
(define (port-sha256* port size)
;; Like 'port-sha256', but limited to SIZE bytes.
(let-values (((out get) (open-sha256-port)))
(dump-port* port out size)
(close-port out)
(get)))
(define (archive-contents port)
"Return a list representing the files contained in the nar read from PORT."
(fold-archive (lambda (file type contents result)
(match type
((or 'regular 'executable)
(match contents
((port . size)
(cons `(,file ,type ,(port-sha256* port size))
result))))
('directory result)
('symlink
(cons `(,file ,type ,contents) result))))
'()
port
""))
(define (store-item-contents item)
"Return a list of files and contents for ITEM in the same format as
'archive-contents'."
(file-system-fold (const #t) ;enter?
(lambda (file stat result) ;leaf
(define short
(string-drop file (string-length item)))
(match (stat:type stat)
('regular
(let ((size (stat:size stat))
(type (if (zero? (logand (stat:mode stat)
#o100))
'regular
'executable)))
(cons `(,short ,type
,(call-with-input-file file
(cut port-sha256* <> size)))
result)))
('symlink
(cons `(,short symlink ,(readlink file))
result))))
(lambda (directory stat result) result) ;down
(lambda (directory stat result) result) ;up
(lambda (file stat result) result) ;skip
(lambda (file stat errno result) result) ;error
'()
item
lstat))
(define (call-with-nar narinfo proc)
"Call PROC with an input port from which it can read the nar pointed to by
NARINFO."
(let*-values (((uri compression size)
(narinfo-best-uri narinfo))
((port response)
(http-fetch uri)))
(define reporter
(progress-reporter/file (narinfo-path narinfo) size
#:abbreviation (const (uri-host uri))))
(define result
(call-with-decompressed-port (string->symbol compression)
(progress-report-port reporter port)
proc))
(close-port port)
(erase-current-line (current-output-port))
result))
(define (narinfo-contents narinfo)
"Fetch the nar described by NARINFO and return a list representing the file
it contains."
(call-with-nar narinfo archive-contents))
(define (differing-files comparison-report)
"Return a list of files that differ among the nars and possibly the local
store item specified in COMPARISON-REPORT."
(define contents
(map narinfo-contents
(comparison-report-narinfos comparison-report)))
(define local-contents
(and (comparison-report-local-sha256 comparison-report)
(store-item-contents (comparison-report-item comparison-report))))
(match (apply lset-difference equal?
(take (delete-duplicates
(if local-contents
(cons local-contents contents)
contents))
2))
(((files _ ...) ...)
files)))
(define (report-differing-files comparison-report)
"Report differences among the nars and possibly the local store item
specified in COMPARISON-REPORT."
(match (differing-files comparison-report)
(()
#t)
((files ...)
(format #t (N_ " differing file:~%"
" differing files:~%"
(length files)))
(format #t "~{ ~a~%~}" files))))
(define (call-with-mismatches comparison-report proc)
"Call PROC with two directories containing the mismatching store items."
(define local-hash
(comparison-report-local-sha256 comparison-report))
(define narinfos
(comparison-report-narinfos comparison-report))
(call-with-temporary-directory
(lambda (directory1)
(call-with-temporary-directory
(lambda (directory2)
(define narinfo1
(if local-hash
(find (lambda (narinfo)
(not (string=? (narinfo-hash narinfo)
local-hash)))
narinfos)
(first (comparison-report-narinfos comparison-report))))
(define narinfo2
(and (not local-hash)
(find (lambda (narinfo)
(not (eq? narinfo narinfo1)))
narinfos)))
(rmdir directory1)
(call-with-nar narinfo1 (cut restore-file <> directory1))
(when narinfo2
(rmdir directory2)
(call-with-nar narinfo2 (cut restore-file <> directory2)))
(proc directory1
(if local-hash
(comparison-report-item comparison-report)
directory2)))))))
(define %diffoscope-command
;; Default external diff command. Pass "--exclude-directory-metadata" so
;; that the mtime/ctime differences are ignored.
'("diffoscope" "--exclude-directory-metadata=yes"))
(define* (report-differing-files/external comparison-report
#:optional
(command %diffoscope-command))
"Run COMMAND to show the file-level differences for the mismatches in
COMPARISON-REPORT."
(call-with-mismatches comparison-report
(lambda (directory1 directory2)
(apply system*
(append command
(list directory1 directory2))))))
(define* (summarize-report comparison-report (define* (summarize-report comparison-report
#:key #:key
(report-differences (const #f))
(hash->string bytevector->nix-base32-string) (hash->string bytevector->nix-base32-string)
verbose?) verbose?)
"Write to the current error port a summary of REPORT, a <comparison-report> "Write to the current error port a summary of COMPARISON-REPORT, a
object. When VERBOSE?, display matches in addition to mismatches and <comparison-report> object. When VERBOSE?, display matches in addition to
inconclusive reports." mismatches and inconclusive reports. Upon mismatch, call REPORT-DIFFERENCES
with COMPARISON-REPORT."
(define (report-hashes item local narinfos) (define (report-hashes item local narinfos)
(if local (if local
(report (G_ " local hash: ~a~%") (hash->string local)) (report (G_ " local hash: ~a~%") (hash->string local))
(report (G_ " no local build for '~a'~%") item)) (report (G_ " no local build for '~a'~%") item))
(for-each (lambda (narinfo) (for-each (lambda (narinfo)
(report (G_ " ~50a: ~a~%") (report (G_ " ~50a: ~a~%")
(uri->string (first (narinfo-uris narinfo))) (uri->string (narinfo-best-uri narinfo))
(hash->string (hash->string
(narinfo-hash->sha256 (narinfo-hash narinfo))))) (narinfo-hash->sha256 (narinfo-hash narinfo)))))
narinfos)) narinfos))
@ -200,7 +381,8 @@ inconclusive reports."
(match comparison-report (match comparison-report
(($ <comparison-report> item 'mismatch local (narinfos ...)) (($ <comparison-report> item 'mismatch local (narinfos ...))
(report (G_ "~a contents differ:~%") item) (report (G_ "~a contents differ:~%") item)
(report-hashes item local narinfos)) (report-hashes item local narinfos)
(report-differences comparison-report))
(($ <comparison-report> item 'inconclusive #f narinfos) (($ <comparison-report> item 'inconclusive #f narinfos)
(warning (G_ "could not challenge '~a': no local build~%") item)) (warning (G_ "could not challenge '~a': no local build~%") item))
(($ <comparison-report> item 'inconclusive locals ()) (($ <comparison-report> item 'inconclusive locals ())
@ -237,6 +419,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
compare build results with those at URLS")) compare build results with those at URLS"))
(display (G_ " (display (G_ "
-v, --verbose show details about successful comparisons")) -v, --verbose show details about successful comparisons"))
(display (G_ "
--diff=MODE show differences according to MODE"))
(newline) (newline)
(display (G_ " (display (G_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
@ -254,6 +438,22 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(lambda args (lambda args
(show-version-and-exit "guix challenge"))) (show-version-and-exit "guix challenge")))
(option '("diff") #t #f
(lambda (opt name arg result . rest)
(define mode
(match arg
("none" (const #t))
("simple" report-differing-files)
("diffoscope" report-differing-files/external)
((and (? (cut string-prefix? "/" <>)) command)
(cute report-differing-files/external <>
(string-tokenize command)))
(_ (leave (G_ "~a: unknown diff mode~%") arg))))
(apply values
(alist-cons 'difference-report mode result)
rest)))
(option '("substitute-urls") #t #f (option '("substitute-urls") #t #f
(lambda (opt name arg result . rest) (lambda (opt name arg result . rest)
(apply values (apply values
@ -269,7 +469,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(define %default-options (define %default-options
`((system . ,(%current-system)) `((system . ,(%current-system))
(substitute-urls . ,%default-substitute-urls))) (substitute-urls . ,%default-substitute-urls)
(difference-report . ,report-differing-files)))
;;; ;;;
@ -286,12 +487,14 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
opts)) opts))
(system (assoc-ref opts 'system)) (system (assoc-ref opts 'system))
(urls (assoc-ref opts 'substitute-urls)) (urls (assoc-ref opts 'substitute-urls))
(diff (assoc-ref opts 'difference-report))
(verbose? (assoc-ref opts 'verbose?))) (verbose? (assoc-ref opts 'verbose?)))
(leave-on-EPIPE (leave-on-EPIPE
(with-store store (with-store store
;; Disable grafts since substitute servers normally provide only ;; Disable grafts since substitute servers normally provide only
;; ungrafted stuff. ;; ungrafted stuff.
(parameterize ((%graft? #f)) (parameterize ((%graft? #f)
(current-terminal-columns (terminal-columns)))
(let ((files (match files (let ((files (match files
(() (()
(filter (cut locally-built? store <>) (filter (cut locally-built? store <>)
@ -305,7 +508,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(mlet* %store-monad ((items (mapm %store-monad (mlet* %store-monad ((items (mapm %store-monad
ensure-store-item files)) ensure-store-item files))
(reports (compare-contents items urls))) (reports (compare-contents items urls)))
(for-each (cut summarize-report <> #:verbose? verbose?) (for-each (cut summarize-report <> #:verbose? verbose?
#:report-differences diff)
reports) reports)
(report "\n") (report "\n")
(summarize-report-list reports) (summarize-report-list reports)

36
guix/scripts/substitute.scm
View file

@ -80,6 +80,7 @@
narinfo-signature narinfo-signature
narinfo-hash->sha256 narinfo-hash->sha256
narinfo-best-uri
lookup-narinfos lookup-narinfos
lookup-narinfos/diverse lookup-narinfos/diverse
@ -822,35 +823,6 @@ was found."
(= (string-length file) 32))))) (= (string-length file) 32)))))
(narinfo-cache-directories directory))) (narinfo-cache-directories directory)))
(define (progress-report-port reporter port)
"Return a port that continuously reports the bytes read from PORT using
REPORTER, which should be a <progress-reporter> object."
(match reporter
(($ <progress-reporter> start report stop)
(let* ((total 0)
(read! (lambda (bv start count)
(let ((n (match (get-bytevector-n! port bv start count)
((? eof-object?) 0)
(x x))))
(set! total (+ total n))
(report total)
n))))
(start)
(make-custom-binary-input-port "progress-port-proc"
read! #f #f
(lambda ()
;; XXX: Kludge! When used through
;; 'decompressed-port', this port ends
;; up being closed twice: once in a
;; child process early on, and at the
;; end in the parent process. Ignore
;; the early close so we don't output
;; a spurious "download-succeeded"
;; trace.
(unless (zero? total)
(stop))
(close-port port)))))))
(define-syntax with-networking (define-syntax with-networking
(syntax-rules () (syntax-rules ()
"Catch DNS lookup errors and TLS errors and gracefully exit." "Catch DNS lookup errors and TLS errors and gracefully exit."
@ -913,7 +885,7 @@ expected by the daemon."
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>) (for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
(narinfo-references narinfo)) (narinfo-references narinfo))
(let-values (((uri compression file-size) (select-uri narinfo))) (let-values (((uri compression file-size) (narinfo-best-uri narinfo)))
(format #t "~a\n~a\n" (format #t "~a\n~a\n"
(or file-size 0) (or file-size 0)
(or (narinfo-size narinfo) 0)))) (or (narinfo-size narinfo) 0))))
@ -967,7 +939,7 @@ this is a rough approximation."
(_ (or (string=? compression2 "none") (_ (or (string=? compression2 "none")
(string=? compression2 "gzip"))))) (string=? compression2 "gzip")))))
(define (select-uri narinfo) (define (narinfo-best-uri narinfo)
"Select the \"best\" URI to download NARINFO's nar, and return three values: "Select the \"best\" URI to download NARINFO's nar, and return three values:
the URI, its compression method (a string), and the compressed file size." the URI, its compression method (a string), and the compressed file size."
(define choices (define choices
@ -1008,7 +980,7 @@ DESTINATION as a nar file. Verify the substitute against ACL."
store-item)) store-item))
(let-values (((uri compression file-size) (let-values (((uri compression file-size)
(select-uri narinfo))) (narinfo-best-uri narinfo)))
;; Tell the daemon what the expected hash of the Nar itself is. ;; Tell the daemon what the expected hash of the Nar itself is.
(format #t "~a~%" (narinfo-hash narinfo)) (format #t "~a~%" (narinfo-hash narinfo))

152
guix/serialization.scm
View file

@ -48,6 +48,7 @@
write-file write-file
write-file-tree write-file-tree
fold-archive
restore-file)) restore-file))
;;; Comment: ;;; Comment:
@ -198,24 +199,6 @@ substitute invalid byte sequences with question marks. This is a
(put-bytevector out buf 0 read) (put-bytevector out buf 0 read)
(loop (- left read)))))))) (loop (- left read))))))))
(define (write-contents file p size)
"Write SIZE bytes from FILE to output port P."
(define (call-with-binary-input-file file proc)
;; Open FILE as a binary file. This avoids scan-for-encoding, and thus
;; avoids any initial buffering. Disable file name canonicalization to
;; avoid stat'ing like crazy.
(with-fluids ((%file-port-name-canonicalization #f))
(let ((port (open-file file "rb")))
(dynamic-wind
(const #t)
(cut proc port)
(lambda ()
(close-port port))))))
(call-with-binary-input-file file
(lambda (input)
(write-contents-from-port input p size))))
(define (write-contents-from-port input output size) (define (write-contents-from-port input output size)
"Write SIZE bytes from port INPUT to port OUTPUT." "Write SIZE bytes from port INPUT to port OUTPUT."
(write-string "contents" output) (write-string "contents" output)
@ -226,38 +209,25 @@ substitute invalid byte sequences with question marks. This is a
(dump input output size)) (dump input output size))
(write-padding size output)) (write-padding size output))
(define (read-contents in out) (define (read-file-type port)
"Read the contents of a file from the Nar at IN, write it to OUT, and return "Read the file type tag from PORT, and return either 'regular or
the size in bytes." 'executable."
(define executable? (match (read-string port)
(match (read-string in) ("contents"
("contents" 'regular)
#f) ("executable"
("executable" (match (list (read-string port) (read-string port))
(match (list (read-string in) (read-string in)) (("" "contents") 'executable)
(("" "contents") #t) (x (raise
(x (raise (condition (&message
(condition (&message (message "unexpected executable file marker"))
(message "unexpected executable file marker")) (&nar-read-error (port port)
(&nar-read-error (port in) (file #f)
(file #f) (token x)))))))
(token x)))))) (x
#t) (raise
(x (condition (&message (message "unsupported nar file type"))
(raise (&nar-read-error (port port) (file #f) (token x)))))))
(condition (&message (message "unsupported nar file type"))
(&nar-read-error (port in) (file #f) (token x)))))))
(let ((size (read-long-long in)))
;; Note: `sendfile' cannot be used here because of port buffering on IN.
(dump in out size)
(when executable?
(chmod out #o755))
(let ((m (modulo size 8)))
(unless (zero? m)
(get-bytevector-n* in (- 8 m))))
size))
(define %archive-version-1 (define %archive-version-1
;; Magic cookie for Nix archives. ;; Magic cookie for Nix archives.
@ -383,9 +353,14 @@ which case you can use 'identity'."
(define port-conversion-strategy (define port-conversion-strategy
(fluid->parameter %default-port-conversion-strategy)) (fluid->parameter %default-port-conversion-strategy))
(define (restore-file port file) (define (fold-archive proc seed port file)
"Read a file (possibly a directory structure) in Nar format from PORT. "Read a file (possibly a directory structure) in Nar format from PORT. Call
Restore it as FILE." PROC on each file or directory read from PORT using:
(PROC FILE TYPE CONTENTS RESULT)
using SEED as the first RESULT. TYPE is a symbol like 'regular, and CONTENTS
depends on TYPE."
(parameterize ((currently-restored-file file) (parameterize ((currently-restored-file file)
;; Error out if we can convert file names to the current ;; Error out if we can convert file names to the current
@ -401,7 +376,8 @@ Restore it as FILE."
(token signature) (token signature)
(file #f)))))) (file #f))))))
(let restore ((file file)) (let read ((file file)
(result seed))
(define (read-eof-marker) (define (read-eof-marker)
(match (read-string port) (match (read-string port)
(")" #t) (")" #t)
@ -414,40 +390,49 @@ Restore it as FILE."
(match (list (read-string port) (read-string port) (read-string port)) (match (list (read-string port) (read-string port) (read-string port))
(("(" "type" "regular") (("(" "type" "regular")
(call-with-output-file file (cut read-contents port <>)) (let* ((type (read-file-type port))
(read-eof-marker)) (size (read-long-long port))
;; The caller must read exactly SIZE bytes from PORT.
(result (proc file type `(,port . ,size) result)))
(let ((m (modulo size 8)))
(unless (zero? m)
(get-bytevector-n* port (- 8 m))))
(read-eof-marker)
result))
(("(" "type" "symlink") (("(" "type" "symlink")
(match (list (read-string port) (read-string port)) (match (list (read-string port) (read-string port))
(("target" target) (("target" target)
(symlink target file) (let ((result (proc file 'symlink target result)))
(read-eof-marker)) (read-eof-marker)
result))
(x (raise (x (raise
(condition (condition
(&message (message "invalid symlink tokens")) (&message (message "invalid symlink tokens"))
(&nar-read-error (port port) (file file) (token x))))))) (&nar-read-error (port port) (file file) (token x)))))))
(("(" "type" "directory") (("(" "type" "directory")
(let ((dir file)) (let ((dir file))
(mkdir dir) (let loop ((prefix (read-string port))
(let loop ((prefix (read-string port))) (result (proc file 'directory #f result)))
(match prefix (match prefix
("entry" ("entry"
(match (list (read-string port) (match (list (read-string port)
(read-string port) (read-string port) (read-string port) (read-string port)
(read-string port)) (read-string port))
(("(" "name" file "node") (("(" "name" file "node")
(restore (string-append dir "/" file)) (let ((result (read (string-append dir "/" file) result)))
(match (read-string port) (match (read-string port)
(")" #t) (")" #f)
(x (x
(raise (raise
(condition (condition
(&message (&message
(message "unexpected directory entry termination")) (message "unexpected directory entry termination"))
(&nar-read-error (port port) (&nar-read-error (port port)
(file file) (file file)
(token x)))))) (token x))))))
(loop (read-string port))))) (loop (read-string port) result)))))
(")" #t) ; done with DIR (")" result) ;done with DIR
(x (x
(raise (raise
(condition (condition
@ -459,6 +444,27 @@ Restore it as FILE."
(&message (message "unsupported nar entry type")) (&message (message "unsupported nar entry type"))
(&nar-read-error (port port) (file file) (token x))))))))) (&nar-read-error (port port) (file file) (token x)))))))))
(define (restore-file port file)
"Read a file (possibly a directory structure) in Nar format from PORT.
Restore it as FILE."
(fold-archive (lambda (file type content result)
(match type
('directory
(mkdir file))
('symlink
(symlink content file))
((or 'regular 'executable)
(match content
((input . size)
(call-with-output-file file
(lambda (output)
(dump input output size)
(when (eq? type 'executable)
(chmod output #o755)))))))))
#t
port
file))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1) ;;; eval: (put 'call-with-binary-input-file 'scheme-indent-function 1)
;;; End: ;;; End:

6
guix/tests/http.scm
View file

@ -65,14 +65,14 @@ needed."
(close-port socket) (close-port socket)
#t))) #t)))
(define (%local-url) (define* (%local-url #:optional (port (%http-server-port)))
;; URL to use for 'home-page' tests. ;; URL to use for 'home-page' tests.
(string-append "http://localhost:" (number->string (%http-server-port)) (string-append "http://localhost:" (number->string port)
"/foo/bar")) "/foo/bar"))
(define* (call-with-http-server responses+data thunk) (define* (call-with-http-server responses+data thunk)
"Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
requests. Each elements of RESPONSES+DATA must be a tuple containing a requests. Each element of RESPONSES+DATA must be a tuple containing a
response and a string, or an HTTP response code and a string." response and a string, or an HTTP response code and a string."
(define responses (define responses
(map (match-lambda (map (match-lambda

96
tests/challenge.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,22 +18,33 @@
(define-module (test-challenge) (define-module (test-challenge)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix tests http)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix serialization)
#:use-module (guix packages)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix base32)
#:use-module (guix scripts challenge) #:use-module (guix scripts challenge)
#:use-module (guix scripts substitute) #:use-module (guix scripts substitute)
#:use-module ((guix build utils) #:select (find-files))
#:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)) #:use-module (ice-9 match))
(define query-path-hash* (define query-path-hash*
(store-lift query-path-hash)) (store-lift query-path-hash))
(define (query-path-size item)
(mlet %store-monad ((info (query-path-info* item)))
(return (path-info-nar-size info))))
(define* (call-with-derivation-narinfo* drv thunk hash) (define* (call-with-derivation-narinfo* drv thunk hash)
(lambda (store) (lambda (store)
(with-derivation-narinfo drv (sha256 => hash) (with-derivation-narinfo drv (sha256 => hash)
@ -138,7 +149,90 @@
(bytevector=? (narinfo-hash->sha256 (bytevector=? (narinfo-hash->sha256
(narinfo-hash narinfo)) (narinfo-hash narinfo))
hash)))))))))))) hash))))))))))))
(define (make-narinfo item size hash)
(format #f "StorePath: ~a
Compression: none
URL: nar/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
NarSize: ~d
NarHash: sha256:~a
References: ~%" item size (bytevector->nix-base32-string hash)))
(define (call-mismatch-test proc)
"Pass PROC a <comparison-report> for a mismatch and return its return
value."
;; Pretend we have two different results for the same store item, ITEM, with
;; "/bin/guile" differing between the two nars.
(mlet* %store-monad
((drv1 (package->derivation %bootstrap-guile))
(drv2 (gexp->derivation
"broken-guile"
(with-imported-modules '((guix build utils))
#~(begin
(use-modules (guix build utils))
(copy-recursively #$drv1 #$output)
(chmod (string-append #$output "/bin/guile")
#o755)
(call-with-output-file (string-append
#$output
"/bin/guile")
(lambda (port)
(display "corrupt!" port)))))))
(out1 -> (derivation->output-path drv1))
(out2 -> (derivation->output-path drv2))
(item -> (string-append (%store-prefix) "/"
(bytevector->nix-base32-string
(random-bytevector 32))
"-foo"
(number->string (current-time) 16))))
(mbegin %store-monad
(built-derivations (list drv1 drv2))
(mlet* %store-monad ((size1 (query-path-size out1))
(size2 (query-path-size out2))
(hash1 (query-path-hash* out1))
(hash2 (query-path-hash* out2))
(nar1 -> (call-with-bytevector-output-port
(lambda (port)
(write-file out1 port))))
(nar2 -> (call-with-bytevector-output-port
(lambda (port)
(write-file out2 port)))))
(parameterize ((%http-server-port 9000))
(with-http-server `((200 ,(make-narinfo item size1 hash1))
(200 ,nar1))
(parameterize ((%http-server-port 9001))
(with-http-server `((200 ,(make-narinfo item size2 hash2))
(200 ,nar2))
(mlet* %store-monad ((urls -> (list (%local-url 9000)
(%local-url 9001)))
(reports (compare-contents (list item)
urls)))
(pk 'report reports)
(return (proc (car reports))))))))))))
(test-assertm "differing-files"
(call-mismatch-test
(lambda (report)
(equal? (differing-files report) '("/bin/guile")))))
(test-assertm "call-with-mismatches"
(call-mismatch-test
(lambda (report)
(call-with-mismatches
report
(lambda (directory1 directory2)
(let* ((files1 (find-files directory1))
(files2 (find-files directory2))
(files (map (cute string-drop <> (string-length directory1))
files1)))
(and (equal? files
(map (cute string-drop <> (string-length directory2))
files2))
(equal? (remove (lambda (file)
(file=? (string-append directory1 "/" file)
(string-append directory2 "/" file)))
files)
'("/bin/guile")))))))))
(test-end) (test-end)

7
tests/guix-archive.sh
View file

@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU # GNU Guix --- Functional package management for GNU
# Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org>
# #
# This file is part of GNU Guix. # This file is part of GNU Guix.
# #
@ -74,5 +74,10 @@ guix archive -x "$tmpdir" < "$archive"
test -x "$tmpdir/bin/guile" test -x "$tmpdir/bin/guile"
test -d "$tmpdir/lib/guile" test -d "$tmpdir/lib/guile"
# Check '--list'.
guix archive -t < "$archive" | grep "^D /share/guile"
guix archive -t < "$archive" | grep "^x /bin/guile"
guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm"
if echo foo | guix archive --authorize if echo foo | guix archive --authorize
then false; else true; fi then false; else true; fi

74
tests/nar.scm
View file

@ -214,6 +214,80 @@
(lambda () (lambda ()
(false-if-exception (rm-rf %test-dir)))))) (false-if-exception (rm-rf %test-dir))))))
(test-equal "write-file-tree + fold-archive"
'(("R" directory #f)
("R/dir" directory #f)
("R/dir/exe" executable "1234")
("R/foo" regular "abcdefg")
("R/lnk" symlink "foo"))
(let ()
(define-values (port get-bytevector)
(open-bytevector-output-port))
(write-file-tree "root" port
#:file-type+size
(match-lambda
("root"
(values 'directory 0))
("root/foo"
(values 'regular 7))
("root/lnk"
(values 'symlink 0))
("root/dir"
(values 'directory 0))
("root/dir/exe"
(values 'executable 4)))
#:file-port
(match-lambda
("root/foo" (open-input-string "abcdefg"))
("root/dir/exe" (open-input-string "1234")))
#:symlink-target
(match-lambda
("root/lnk" "foo"))
#:directory-entries
(match-lambda
("root" '("foo" "dir" "lnk"))
("root/dir" '("exe"))))
(close-port port)
(reverse
(fold-archive (lambda (file type contents result)
(let ((contents (if (memq type '(regular executable))
(utf8->string
(get-bytevector-n (car contents)
(cdr contents)))
contents)))
(cons `(,file ,type ,contents)
result)))
'()
(open-bytevector-input-port (get-bytevector))
"R"))))
(test-equal "write-file-tree + fold-archive, flat file"
'(("R" regular "abcdefg"))
(let ()
(define-values (port get-bytevector)
(open-bytevector-output-port))
(write-file-tree "root" port
#:file-type+size
(match-lambda
("root" (values 'regular 7)))
#:file-port
(match-lambda
("root" (open-input-string "abcdefg"))))
(close-port port)
(reverse
(fold-archive (lambda (file type contents result)
(let ((contents (utf8->string
(get-bytevector-n (car contents)
(cdr contents)))))
(cons `(,file ,type ,contents) result)))
'()
(open-bytevector-input-port (get-bytevector))
"R"))))
(test-assert "write-file supports non-file output ports" (test-assert "write-file supports non-file output ports"
(let ((input (string-append (dirname (search-path %load-path "guix.scm")) (let ((input (string-append (dirname (search-path %load-path "guix.scm"))
"/guix")) "/guix"))