nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into core-updates

This commit is contained in:
Ludovic Courtès 2018-06-01 23:41:40 +02:00
parent babeea3f9f 1a3e3162ac
commit a13c1bf4ca
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
43 changed files with 1972 additions and 454 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.dir-locals.el
View File

@ -73,6 +73,9 @@
(eval . (put 'run-with-state 'scheme-indent-function 1)) (eval . (put 'run-with-state 'scheme-indent-function 1))
(eval . (put 'wrap-program 'scheme-indent-function 1)) (eval . (put 'wrap-program 'scheme-indent-function 1))
(eval . (put 'with-imported-modules 'scheme-indent-function 1)) (eval . (put 'with-imported-modules 'scheme-indent-function 1))
(eval . (put 'with-extensions 'scheme-indent-function 1))
(eval . (put 'with-database 'scheme-indent-function 2))
(eval . (put 'call-with-container 'scheme-indent-function 1)) (eval . (put 'call-with-container 'scheme-indent-function 1))
(eval . (put 'container-excursion 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1))

19
Makefile.am
View File

@ -257,6 +257,17 @@ MODULES += \
endif BUILD_DAEMON_OFFLOAD endif BUILD_DAEMON_OFFLOAD
# Scheme implementation of the build daemon and related functionality.
STORE_MODULES = \
guix/store/database.scm \
guix/store/deduplication.scm
if HAVE_GUILE_SQLITE3
MODULES += $(STORE_MODULES)
else
MODULES_NOT_COMPILED += $(STORE_MODULES)
endif !HAVE_GUILE_SQLITE3
# Internal modules with test suite support. # Internal modules with test suite support.
dist_noinst_DATA = guix/tests.scm guix/tests/http.scm dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
@ -379,6 +390,14 @@ SCM_TESTS += \
endif endif
if HAVE_GUILE_SQLITE3
SCM_TESTS += \
tests/store-database.scm \
tests/store-deduplication.scm
endif
SH_TESTS = \ SH_TESTS = \
tests/guix-build.sh \ tests/guix-build.sh \
tests/guix-download.sh \ tests/guix-download.sh \

5
configure.ac
View File

@ -124,6 +124,11 @@ dnl Guile-JSON is used in various places.
GUILE_MODULE_AVAILABLE([have_guile_json], [(json)]) GUILE_MODULE_AVAILABLE([have_guile_json], [(json)])
AM_CONDITIONAL([HAVE_GUILE_JSON], [test "x$have_guile_json" = "xyes"]) AM_CONDITIONAL([HAVE_GUILE_JSON], [test "x$have_guile_json" = "xyes"])
dnl Guile-Sqlite3 is used by the (guix store ...) modules.
GUIX_CHECK_GUILE_SQLITE3
AM_CONDITIONAL([HAVE_GUILE_SQLITE3],
[test "x$guix_cv_have_recent_guile_sqlite3" = "xyes"])
dnl Make sure we have a full-fledged Guile. dnl Make sure we have a full-fledged Guile.
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])

94
doc/guix.texi
View File

@ -47,7 +47,8 @@ Copyright @copyright{} 2017, 2018 Arun Isaac@*
Copyright @copyright{} 2017 nee@* Copyright @copyright{} 2017 nee@*
Copyright @copyright{} 2018 Rutger Helling@* Copyright @copyright{} 2018 Rutger Helling@*
Copyright @copyright{} 2018 Oleg Pykhalov@* Copyright @copyright{} 2018 Oleg Pykhalov@*
Copyright @copyright{} 2018 Mike Gerwitz Copyright @copyright{} 2018 Mike Gerwitz@*
Copyright @copyright{} 2018 Pierre-Antoine Rouby
Permission is granted to copy, distribute and/or modify this document Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or under the terms of the GNU Free Documentation License, Version 1.3 or
@ -5063,6 +5064,23 @@ headers, which comes in handy in this case:
@dots{}))) @dots{})))
@end example @end example
@cindex extensions, for gexps
@findex with-extensions
In the same vein, sometimes you want to import not just pure-Scheme
modules, but also ``extensions'' such as Guile bindings to C libraries
or other ``full-blown'' packages. Say you need the @code{guile-json}
package available on the build side, here's how you would do it:
@example
(use-modules (gnu packages guile)) ;for 'guile-json'
(with-extensions (list guile-json)
(gexp->derivation "something-with-json"
#~(begin
(use-modules (json))
@dots{})))
@end example
The syntactic form to construct gexps is summarized below. The syntactic form to construct gexps is summarized below.
@deffn {Scheme Syntax} #~@var{exp} @deffn {Scheme Syntax} #~@var{exp}
@ -5146,6 +5164,18 @@ directly defined in @var{body}@dots{}, but not on those defined, say, in
procedures called from @var{body}@dots{}. procedures called from @var{body}@dots{}.
@end deffn @end deffn
@deffn {Scheme Syntax} with-extensions @var{extensions} @var{body}@dots{}
Mark the gexps defined in @var{body}@dots{} as requiring
@var{extensions} in their build and execution environment.
@var{extensions} is typically a list of package objects such as those
defined in the @code{(gnu packages guile)} module.
Concretely, the packages listed in @var{extensions} are added to the
load path while compiling imported modules in @var{body}@dots{}; they
are also added to the load path of the gexp returned by
@var{body}@dots{}.
@end deffn
@deffn {Scheme Procedure} gexp? @var{obj} @deffn {Scheme Procedure} gexp? @var{obj}
Return @code{#t} if @var{obj} is a G-expression. Return @code{#t} if @var{obj} is a G-expression.
@end deffn @end deffn
@ -5160,6 +5190,7 @@ information about monads.)
[#:hash #f] [#:hash-algo #f] @ [#:hash #f] [#:hash-algo #f] @
[#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
[#:module-path @var{%load-path}] @ [#:module-path @var{%load-path}] @
[#:effective-version "2.2"] @
[#:references-graphs #f] [#:allowed-references #f] @ [#:references-graphs #f] [#:allowed-references #f] @
[#:disallowed-references #f] @ [#:disallowed-references #f] @
[#:leaked-env-vars #f] @ [#:leaked-env-vars #f] @
@ -5180,6 +5211,9 @@ make @var{modules} available in the evaluation context of @var{exp};
the load path during the execution of @var{exp}---e.g., @code{((guix the load path during the execution of @var{exp}---e.g., @code{((guix
build utils) (guix build gnu-build-system))}. build utils) (guix build gnu-build-system))}.
@var{effective-version} determines the string to use when adding extensions of
@var{exp} (see @code{with-extensions}) to the search path---e.g., @code{"2.2"}.
@var{graft?} determines whether packages referred to by @var{exp} should be grafted when @var{graft?} determines whether packages referred to by @var{exp} should be grafted when
applicable. applicable.
@ -16159,6 +16193,64 @@ A simple setup for cat-avatar-generator can look like this:
%base-services)) %base-services))
@end example @end example
@subsubheading Hpcguix-web
@cindex hpcguix-web
The @uref{hpcguix-web, https://github.com/UMCUGenetics/hpcguix-web/}
program is a customizable web interface to browse Guix packages,
initially designed for users of high-performance computing (HPC)
clusters.
@defvr {Scheme Variable} hpcguix-web-service-type
The service type for @code{hpcguix-web}.
@end defvr
@deftp {Data Type} hpcguix-web-configuration
Data type for the hpcguix-web service configuration.
@table @asis
@item @code{specs}
A gexp (@pxref{G-Expressions}) specifying the hpcguix-web service
configuration. The main items available in this spec are:
@table @asis
@item @code{title-prefix} (default: @code{"hpcguix | "})
The page title prefix.
@item @code{guix-command} (default: @code{"guix"})
The @command{guix} command.
@item @code{package-filter-proc} (default: @code{(const #t)})
A procedure specifying how to filter packages that are displayed.
@item @code{package-page-extension-proc} (default: @code{(const '())})
Extension package for @code{hpcguix-web}.
@item @code{menu} (default: @code{'()})
Additional entry in page @code{menu}.
@end table
See the hpcguix-web repository for a
@uref{https://github.com/UMCUGenetics/hpcguix-web/blob/master/hpcweb-configuration.scm,
complete example}.
@item @code{package} (default: @code{hpcguix-web})
The hpcguix-web package to use.
@end table
@end deftp
A typical hpcguix-web service declaration looks like this:
@example
(service hpcguix-web-service-type
(hpcguix-web-configuration
(specs
#~(define site-config
(hpcweb-configuration
(title-prefix "Guix-HPC - ")
(menu '(("/about" "ABOUT"))))))))
@end example
@node Certificate Services @node Certificate Services
@subsubsection Certificate Services @subsubsection Certificate Services

19
gnu/bootloader/grub.scm
View File

@ -121,25 +121,14 @@ otherwise."
(define* (svg->png svg #:key width height) (define* (svg->png svg #:key width height)
"Build a PNG of HEIGHT x WIDTH from SVG." "Build a PNG of HEIGHT x WIDTH from SVG."
;; Note: Guile-RSVG & co. are now built for Guile 2.2, so we use 2.2 here. (gexp->derivation "grub-image.png"
;; TODO: Remove #:guile-for-build when 2.2 has become the default. (with-imported-modules '((gnu build svg))
(mlet %store-monad ((guile (package->derivation guile-2.2 #:graft? #f))) (with-extensions (list guile-rsvg guile-cairo)
(gexp->derivation "grub-image.png"
(with-imported-modules '((gnu build svg))
#~(begin #~(begin
;; We need these two libraries.
(add-to-load-path (string-append #+guile-rsvg
"/share/guile/site/"
(effective-version)))
(add-to-load-path (string-append #+guile-cairo
"/share/guile/site/"
(effective-version)))
(use-modules (gnu build svg)) (use-modules (gnu build svg))
(svg->png #+svg #$output (svg->png #+svg #$output
#:width #$width #:width #$width
#:height #$height))) #:height #$height))))))
#:guile-for-build guile)))
(define* (grub-background-image config #:key (width 1024) (height 768)) (define* (grub-background-image config #:key (width 1024) (height 768))
"Return the GRUB background image defined in CONFIG with a ratio of "Return the GRUB background image defined in CONFIG with a ratio of

4
gnu/build/file-systems.scm
View File

@ -499,8 +499,8 @@ were found."
(match spec (match spec
((? string?) ((? string?)
;; Nothing to do. ;; Nothing to do, but wait until SPEC shows up.
spec) (resolve identity spec identity))
((? file-system-label?) ((? file-system-label?)
;; Resolve the label. ;; Resolve the label.
(resolve find-partition-by-label (resolve find-partition-by-label

27
gnu/build/marionette.scm
View File

@ -26,6 +26,7 @@
make-marionette make-marionette
marionette-eval marionette-eval
wait-for-file wait-for-file
wait-for-tcp-port
marionette-control marionette-control
marionette-screen-text marionette-screen-text
wait-for-screen-text wait-for-screen-text
@ -187,6 +188,32 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
('failure ('failure
(error "file didn't show up" file)))) (error "file didn't show up" file))))
(define* (wait-for-tcp-port port marionette
#:key (timeout 20))
"Wait for up to TIMEOUT seconds for PORT to accept connections in
MARIONETTE. Raise an error on failure."
;; Note: The 'connect' loop has to run within the guest because, when we
;; forward ports to the host, connecting to the host never raises
;; ECONNREFUSED.
(match (marionette-eval
`(begin
(let ((sock (socket PF_INET SOCK_STREAM 0)))
(let loop ((i 0))
(catch 'system-error
(lambda ()
(connect sock AF_INET INADDR_LOOPBACK ,port)
'success)
(lambda args
(if (< i ,timeout)
(begin
(sleep 1)
(loop (+ 1 i)))
'failure))))))
marionette)
('success #t)
('failure
(error "nobody's listening on port" port))))
(define (marionette-control command marionette) (define (marionette-control command marionette)
"Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as "Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as
\"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc) \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc)

11
gnu/build/svg.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com> ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -18,16 +18,11 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build svg) (define-module (gnu build svg)
#:use-module (rsvg)
#:use-module (cairo)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:export (svg->png)) #:export (svg->png))
;; We need Guile-RSVG and Guile-Cairo. Load them lazily, at run time, to
;; allow compilation to proceed. See also <http://bugs.gnu.org/12202>.
(module-autoload! (current-module)
'(rsvg) '(rsvg-handle-new-from-file))
(module-autoload! (current-module)
'(cairo) '(cairo-image-surface-create))
(define* (downscaled-surface surface (define* (downscaled-surface surface
#:key #:key
source-width source-height source-width source-height

1
gnu/local.mk
View File

@ -1092,6 +1092,7 @@ dist_patch_DATA = \
%D%/packages/patches/scotch-build-parallelism.patch \ %D%/packages/patches/scotch-build-parallelism.patch \
%D%/packages/patches/scotch-graph-diam-64.patch \ %D%/packages/patches/scotch-graph-diam-64.patch \
%D%/packages/patches/scotch-graph-induce-type-64.patch \ %D%/packages/patches/scotch-graph-induce-type-64.patch \
%D%/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch \
%D%/packages/patches/sdl-libx11-1.6.patch \ %D%/packages/patches/sdl-libx11-1.6.patch \
%D%/packages/patches/seq24-rename-mutex.patch \ %D%/packages/patches/seq24-rename-mutex.patch \
%D%/packages/patches/sharutils-CVE-2018-1000097.patch \ %D%/packages/patches/sharutils-CVE-2018-1000097.patch \

2
gnu/packages/build-tools.scm
View File

@ -87,6 +87,8 @@ makes a few sacrifices to acquire fast full and incremental build times.")
(base32 (base32
"1m0w0wqnz983l7fpp5p9pdsqr7n3ybrzp8ywjcvn0rihsrzj65j6")))) "1m0w0wqnz983l7fpp5p9pdsqr7n3ybrzp8ywjcvn0rihsrzj65j6"))))
(build-system cmake-build-system) (build-system cmake-build-system)
(inputs
`(("python" ,python-wrapper)))
(home-page "https://github.com/rizsotto/Bear") (home-page "https://github.com/rizsotto/Bear")
(synopsis "Tool for generating a compilation database") (synopsis "Tool for generating a compilation database")
(description "A JSON compilation database is used in the Clang project to (description "A JSON compilation database is used in the Clang project to

4
gnu/packages/display-managers.scm
View File

@ -6,6 +6,7 @@
;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Stefan Stefanović <stefanx2ovic@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -143,7 +144,8 @@ Qt-style API for Wayland clients.")
"sddm-" version ".tar.xz")) "sddm-" version ".tar.xz"))
(sha256 (sha256
(base32 (base32
"0ch6rdppgy2vbzw0c2x9a4c6ry46vx7p6b76d8xbh2nvxh23xv0k")))) "0ch6rdppgy2vbzw0c2x9a4c6ry46vx7p6b76d8xbh2nvxh23xv0k"))
(patches (search-patches "sddm-fix-build-with-qt-5.11-1024.patch"))))
(build-system cmake-build-system) (build-system cmake-build-system)
(native-inputs (native-inputs
`(("extra-cmake-modules" ,extra-cmake-modules) `(("extra-cmake-modules" ,extra-cmake-modules)

205
gnu/packages/emacs.scm
View File

@ -751,77 +751,91 @@ provides an optional IDE-like error list.")
;;; ;;;
(define-public emacs-w3m (define-public emacs-w3m
(package ;; Emacs-w3m follows a "rolling release" model from its CVS repo. We could
(name "emacs-w3m") ;; use CVS, sure, but instead we choose to use this Git mirror described on
(version "1.4.538+0.20141022") ;; the home page as an "unofficial" mirror.
(source (origin (let ((commit "0dd5691f46d314a84da63f3a7277d721815811a2"))
(method url-fetch) (package
(uri (string-append "mirror://debian/pool/main/w/w3m-el/w3m-el_" (name "emacs-w3m")
version ".orig.tar.gz")) (version (git-version "1.5" "0" commit))
(sha256 (source (origin
(base32 (method git-fetch)
"0zfxmq86pwk64yv0426gnjrvhjrgrjqn08sdcdhmmjmfpmqvm79y")))) (uri (git-reference
(build-system gnu-build-system) (url "https://github.com/ecbrown/emacs-w3m")
(native-inputs `(("autoconf" ,autoconf) (commit commit)))
("emacs" ,emacs-minimal))) (sha256
(inputs `(("w3m" ,w3m) (base32
("imagemagick" ,imagemagick))) "02xalyxbrkgl4n8nj7xxkmsbm6lshhwdc8bzs2l4wz3hkpgkj7x4"))))
(arguments (build-system gnu-build-system)
`(#:modules ((guix build gnu-build-system) (native-inputs `(("autoconf" ,autoconf)
(guix build utils) ("texinfo" ,texinfo)
(guix build emacs-utils)) ("emacs" ,emacs-minimal)))
#:imported-modules (,@%gnu-build-system-modules (inputs `(("w3m" ,w3m)
(guix build emacs-utils)) ("imagemagick" ,imagemagick)))
#:configure-flags (arguments
(let ((out (assoc-ref %outputs "out"))) `(#:modules ((guix build gnu-build-system)
(list (string-append "--with-lispdir=" (guix build utils)
out "/share/emacs/site-lisp") (guix build emacs-utils))
(string-append "--with-icondir=" #:imported-modules (,@%gnu-build-system-modules
out "/share/images/emacs-w3m") (guix build emacs-utils))
;; Leave .el files uncompressed, otherwise GC can't #:configure-flags
;; identify run-time dependencies. See (let ((out (assoc-ref %outputs "out")))
;; <http://lists.gnu.org/archive/html/guix-devel/2015-12/msg00208.html> (list (string-append "--with-lispdir="
"--without-compress-install")) out "/share/emacs/site-lisp")
#:tests? #f ; no check target (string-append "--with-icondir="
#:phases out "/share/images/emacs-w3m")
(modify-phases %standard-phases ;; Leave .el files uncompressed, otherwise GC can't
(add-after 'unpack 'autoconf ;; identify run-time dependencies. See
(lambda _ ;; <http://lists.gnu.org/archive/html/guix-devel/2015-12/msg00208.html>
(zero? (system* "autoconf")))) "--without-compress-install"))
(add-before 'build 'patch-exec-paths #:tests? #f ; no check target
(lambda* (#:key inputs outputs #:allow-other-keys) #:phases
(let ((out (assoc-ref outputs "out")) (modify-phases %standard-phases
(w3m (assoc-ref inputs "w3m")) (add-after 'unpack 'autoconf
(imagemagick (assoc-ref inputs "imagemagick")) (lambda _
(coreutils (assoc-ref inputs "coreutils"))) (zero? (system* "autoconf"))))
(emacs-substitute-variables "w3m.el" (add-before 'configure 'support-emacs!
("w3m-command" (string-append w3m "/bin/w3m")) (lambda _
("w3m-touch-command" ;; For some reason 'AC_PATH_EMACS' thinks that 'Emacs 26' is
(string-append coreutils "/bin/touch")) ;; unsupported.
("w3m-image-viewer" (substitute* "configure"
(string-append imagemagick "/bin/display")) (("EMACS_FLAVOR=unsupported")
("w3m-icon-directory" "EMACS_FLAVOR=emacs"))
(string-append out "/share/images/emacs-w3m"))) #t))
(emacs-substitute-variables "w3m-image.el" (add-before 'build 'patch-exec-paths
("w3m-imagick-convert-program" (lambda* (#:key inputs outputs #:allow-other-keys)
(string-append imagemagick "/bin/convert")) (let ((out (assoc-ref outputs "out"))
("w3m-imagick-identify-program" (w3m (assoc-ref inputs "w3m"))
(string-append imagemagick "/bin/identify"))) (imagemagick (assoc-ref inputs "imagemagick"))
#t))) (coreutils (assoc-ref inputs "coreutils")))
(replace 'install (make-file-writable "w3m.el")
(lambda* (#:key outputs #:allow-other-keys) (emacs-substitute-variables "w3m.el"
(and (zero? (system* "make" "install" "install-icons")) ("w3m-command" (string-append w3m "/bin/w3m"))
(with-directory-excursion ("w3m-touch-command"
(string-append (assoc-ref outputs "out") (string-append coreutils "/bin/touch"))
"/share/emacs/site-lisp") ("w3m-icon-directory"
(for-each delete-file '("ChangeLog" "ChangeLog.1")) (string-append out "/share/images/emacs-w3m")))
(symlink "w3m-load.el" "w3m-autoloads.el") (make-file-writable "w3m-image.el")
#t))))))) (emacs-substitute-variables "w3m-image.el"
(home-page "http://emacs-w3m.namazu.org/") ("w3m-imagick-convert-program"
(synopsis "Simple Web browser for Emacs based on w3m") (string-append imagemagick "/bin/convert"))
(description ("w3m-imagick-identify-program"
"Emacs-w3m is an emacs interface for the w3m web browser.") (string-append imagemagick "/bin/identify")))
(license license:gpl2+))) #t)))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(and (zero? (system* "make" "install" "install-icons"))
(with-directory-excursion
(string-append (assoc-ref outputs "out")
"/share/emacs/site-lisp")
(for-each delete-file '("ChangeLog" "ChangeLog.1"))
(symlink "w3m-load.el" "w3m-autoloads.el")
#t)))))))
(home-page "http://emacs-w3m.namazu.org/")
(synopsis "Simple Web browser for Emacs based on w3m")
(description
"Emacs-w3m is an emacs interface for the w3m web browser.")
(license license:gpl2+))))
(define-public emacs-wget (define-public emacs-wget
(package (package
@ -10571,3 +10585,52 @@ well as take screenshots and lock your screen. The package depends on the
availability of shell commands to do the hard work for us. These commands can availability of shell commands to do the hard work for us. These commands can
be changed by customizing the appropriate variables.") be changed by customizing the appropriate variables.")
(license license:gpl3+))) (license license:gpl3+)))
(define-public emacs-org-caldav
(package
(name "emacs-org-caldav")
(version "20180403")
(source
(origin
(method url-fetch)
(uri (string-append
"https://github.com/dengste/org-caldav/raw/"
"8d3492c27a09f437d2d94f2736c56d7652e87aa0"
"/org-caldav.el"))
(sha256
(base32
"1fh4gh68ddj0is99z2ccyh97v6psnyda61n2dsadzqhcxn51amlc"))))
(build-system emacs-build-system)
(propagated-inputs `(("emacs-org" ,emacs-org)))
(home-page "https://github.com/dengste/org-caldav")
(synopsis
"Sync Org files with external calendars via the CalDAV protocol")
(description
"Synchronize between events in Org-mode files and a CalDAV calendar.
This code is still alpha.")
(license license:gpl3+)))
(define-public emacs-zotxt
(package
(name "emacs-zotxt")
(version "20180518")
(source
(origin
(method url-fetch)
(uri (string-append
"https://github.com/egh/zotxt-emacs/archive/"
"23a4a9f74a658222027d53a9a83cd4bcc583ca8b"
".tar.gz"))
(sha256
(base32
"1qlibaciqgsva6fc7vv9krssjq00bi880396jk7llbi3c52q9n1y"))))
(build-system emacs-build-system)
(propagated-inputs
`(("emacs-deferred" ,emacs-deferred)
("emacs-request" ,emacs-request)))
(home-page "https://github.com/egh/zotxt-emacs")
(synopsis "Integrate Emacs with Zotero")
(description "This package provides two integration features between Emacs
and the Zotero research assistant: Insertion of links to Zotero items into an
Org-mode file, and citations of Zotero items in Pandoc Markdown files.")
(license license:gpl3+)))

12
gnu/packages/gnuzilla.scm
View File

@ -489,7 +489,17 @@ security standards.")
(mozilla-patch "icecat-bug-1459206-pt2.patch" "9ad16112044a" "0ayya67sx7avcb8bplfdxb92l9g4mjrb1s3hby283llhqv0ikg9b") (mozilla-patch "icecat-bug-1459206-pt2.patch" "9ad16112044a" "0ayya67sx7avcb8bplfdxb92l9g4mjrb1s3hby283llhqv0ikg9b")
(mozilla-patch "icecat-bug-1459162.patch" "11d8a87fb6d6" "1rkmdk18llw0x1jakix75hlhy0hpsmlminnflagbzrzjli81gwm1") (mozilla-patch "icecat-bug-1459162.patch" "11d8a87fb6d6" "1rkmdk18llw0x1jakix75hlhy0hpsmlminnflagbzrzjli81gwm1")
(mozilla-patch "icecat-bug-1451297.patch" "407b10ad1273" "16qzsfirw045xag96f1qvpdlibm8lwdj9l1mlli4n1vz0db91v9q") (mozilla-patch "icecat-bug-1451297.patch" "407b10ad1273" "16qzsfirw045xag96f1qvpdlibm8lwdj9l1mlli4n1vz0db91v9q")
(mozilla-patch "icecat-bug-1462682.patch" "e76e2e481b17" "0hnx13msjy28n3bpa2c24kpzalam4bdk5gnp0f9k671l48rs9yb3"))) (mozilla-patch "icecat-bug-1462682.patch" "e76e2e481b17" "0hnx13msjy28n3bpa2c24kpzalam4bdk5gnp0f9k671l48rs9yb3")
(mozilla-patch "icecat-bug-1450688.patch" "2c75bfcd465c" "1pjinj8qypafqm2fk68s3hzcbzcijn09qzrpcxvzq6bl1yfc1xfd")
(mozilla-patch "icecat-bug-1456975.patch" "042f80f3befd" "0av918kin4bkrq7gnjz0h9w8kkq8rk9l93250lfl5kqrinza1gsk")
(mozilla-patch "icecat-bugs-1442722+1455071+1433642+1456604+1458320.patch"
"bb0451c9c4a0" "1lhm1b2a7c6jwhzsg3c830hfhp17p8j9zbcmgchpb8c5jkc3vw0x")
(mozilla-patch "icecat-bug-1465108-pt1.patch" "8189b262e3b9" "13rh86ddwmj1bhv3ibbil3sv5xbqq1c9v1czgbsna5hxxkzc1y3b")
(mozilla-patch "icecat-bug-1465108-pt2.patch" "9f81ae3f6e1d" "05vfg8a8jrzd93n1wvncmvdmqgf9cgsl8ryxgjs3032gbbjkga7q")
(mozilla-patch "icecat-bug-1459693.patch" "face7a3dd5d7" "0jclw30mf693w8lrmvn0iankggj21nh4j3zh51q5363rj5xncdzx")
(mozilla-patch "icecat-bug-1464829.patch" "7afb58c046c8" "1r0569r76712x7x1sw6xr0x06ilv6iw3fncb0f8r8b9mp6wrpx34")
(mozilla-patch "icecat-bug-1452375-pt1.patch" "f1a745f8c42d" "11q73pb7a8f09xjzil4rhg5nr49zrnz1vb0prni0kqvrnppf5s40")
(mozilla-patch "icecat-bug-1452375-pt2.patch" "1f9a430881cc" "0f79rv7njliqxx33z07n60b50jg0a596d1km7ayz2hivbl2d0168")))
(modules '((guix build utils))) (modules '((guix build utils)))
(snippet (snippet
'(begin '(begin

160
gnu/packages/haskell.scm
View File

@ -14,6 +14,7 @@
;;; Copyright © 2017 rsiddharth <s@ricketyspace.net> ;;; Copyright © 2017 rsiddharth <s@ricketyspace.net>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Tonton <tonton@riseup.net> ;;; Copyright © 2018 Tonton <tonton@riseup.net>
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -1940,6 +1941,30 @@ case with other forms of concurrent communication, such as locks or
"This package provides a library for parallel programming.") "This package provides a library for parallel programming.")
(license license:bsd-3))) (license license:bsd-3)))
(define-public ghc-safesemaphore
(package
(name "ghc-safesemaphore")
(version "0.10.1")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"SafeSemaphore/SafeSemaphore-" version ".tar.gz"))
(sha256
(base32
"0rpg9j6fy70i0b9dkrip9d6wim0nac0snp7qzbhykjkqlcvvgr91"))))
(build-system haskell-build-system)
(inputs
`(("ghc-stm" ,ghc-stm)))
(native-inputs
`(("ghc-hunit" ,ghc-hunit)))
(home-page "https://github.com/ChrisKuklewicz/SafeSemaphore")
(synopsis "Exception safe semaphores")
(description "This library provides exception safe semaphores that can be
used in place of @code{QSem}, @code{QSemN}, and @code{SampleVar}, all of which
are not exception safe and can be broken by @code{killThread}.")
(license license:bsd-3)))
(define-public ghc-text (define-public ghc-text
(package (package
(name "ghc-text") (name "ghc-text")
@ -2990,6 +3015,35 @@ online}.")
(description "This package provides a simple XML library for Haskell.") (description "This package provides a simple XML library for Haskell.")
(license license:bsd-3))) (license license:bsd-3)))
(define-public ghc-feed
(package
(name "ghc-feed")
(version "0.3.12.0")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"feed/feed-" version ".tar.gz"))
(sha256
(base32
"0hkrsinspg70bbm3hwqdrvivws6zya1hyk0a3awpaz82j4xnlbfc"))))
(build-system haskell-build-system)
(inputs
`(("ghc-old-locale" ,ghc-old-locale)
("ghc-old-time" ,ghc-old-time)
("ghc-time-locale-compat" ,ghc-time-locale-compat)
("ghc-utf8-string" ,ghc-utf8-string)
("ghc-xml" ,ghc-xml)))
(native-inputs
`(("ghc-hunit" ,ghc-hunit)
("ghc-test-framework" ,ghc-test-framework)
("ghc-test-framework-hunit" ,ghc-test-framework-hunit)))
(home-page "https://github.com/bergmark/feed")
(synopsis "Haskell package for handling various syndication formats")
(description "This Haskell package includes tools for generating and
consuming feeds in both RSS (Really Simple Syndication) and Atom format.")
(license license:bsd-3)))
(define-public ghc-exceptions (define-public ghc-exceptions
(package (package
(name "ghc-exceptions") (name "ghc-exceptions")
@ -3575,6 +3629,31 @@ vector types are supported. Specific instances are provided for unboxed,
boxed and storable vectors.") boxed and storable vectors.")
(license license:bsd-3))) (license license:bsd-3)))
(define-public ghc-bloomfilter
(package
(name "ghc-bloomfilter")
(version "2.0.1.0")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"bloomfilter/bloomfilter-" version ".tar.gz"))
(sha256
(base32
"03vrmncg1c10a2wcg5skq30m1yiknn7nwxz2gblyyfaxglshspkc"))))
(build-system haskell-build-system)
(native-inputs
`(("ghc-quickcheck" ,ghc-quickcheck)
("ghc-random" ,ghc-random)
("ghc-test-framework" ,ghc-test-framework)
("ghc-test-framework-quickcheck2" ,ghc-test-framework-quickcheck2)))
(home-page "https://github.com/bos/bloomfilter")
(synopsis "Pure and impure Bloom filter implementations")
(description "This package provides both mutable and immutable Bloom
filter data types, along with a family of hash functions and an easy-to-use
interface.")
(license license:bsd-3)))
(define-public ghc-network (define-public ghc-network
(package (package
(name "ghc-network") (name "ghc-network")
@ -3760,6 +3839,27 @@ with various performance characteristics.")
manipulating monad transformer stacks.") manipulating monad transformer stacks.")
(license license:bsd-3))) (license license:bsd-3)))
(define-public ghc-ifelse
(package
(name "ghc-ifelse")
(version "0.85")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"IfElse/IfElse-" version ".tar.gz"))
(sha256
(base32
"1kfx1bwfjczj93a8yqz1n8snqiq5655qgzwv1lrycry8wb1vzlwa"))))
(build-system haskell-build-system)
(inputs `(("ghc-mtl" ,ghc-mtl)))
(home-page "http://hackage.haskell.org/package/IfElse")
(synopsis "Monadic control flow with anaphoric variants")
(description "This library provides functions for control flow inside of
monads with anaphoric variants on @code{if} and @code{when} and a C-like
@code{switch} function.")
(license license:bsd-3)))
(define-public ghc-monad-control (define-public ghc-monad-control
(package (package
(name "ghc-monad-control") (name "ghc-monad-control")
@ -7738,6 +7838,44 @@ converting between Haskell values and JSON.
JSON (JavaScript Object Notation) is a lightweight data-interchange format.") JSON (JavaScript Object Notation) is a lightweight data-interchange format.")
(license license:bsd-3))) (license license:bsd-3)))
(define-public ghc-esqueleto
(package
(name "ghc-esqueleto")
(version "2.5.3")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"esqueleto/esqueleto-" version ".tar.gz"))
(sha256
(base32
"10n49rzqmblky7pwjnysalyy6nacmxfms8dqbsdv6hlyzr8pb69x"))))
(build-system haskell-build-system)
(inputs
`(("ghc-blaze-html" ,ghc-blaze-html)
("ghc-conduit" ,ghc-conduit)
("ghc-monad-logger" ,ghc-monad-logger)
("ghc-persistent" ,ghc-persistent)
("ghc-resourcet" ,ghc-resourcet)
("ghc-tagged" ,ghc-tagged)
("ghc-text" ,ghc-text)
("ghc-unordered-containers" ,ghc-unordered-containers)))
(native-inputs
`(("ghc-hspec" ,ghc-hspec)
("ghc-hunit" ,ghc-hunit)
("ghc-monad-control" ,ghc-monad-control)
("ghc-persistent-sqlite" ,ghc-persistent-sqlite)
("ghc-persistent-template" ,ghc-persistent-template)
("ghc-quickcheck" ,ghc-quickcheck)))
(home-page "https://github.com/bitemyapp/esqueleto")
(synopsis "Type-safe embedded domain specific language for SQL queries")
(description "This library provides a type-safe embedded domain specific
language (EDSL) for SQL queries that works with SQL backends as provided by
@code{ghc-persistent}. Its language closely resembles SQL, so you don't have
to learn new concepts, just new syntax, and it's fairly easy to predict the
generated SQL and optimize it for your backend.")
(license license:bsd-3)))
(define-public shellcheck (define-public shellcheck
(package (package
(name "shellcheck") (name "shellcheck")
@ -7836,6 +7974,8 @@ bytestrings and their hexademical representation.")
(base32 (base32
"0n39s1i88j6s7vvsdhpbhcr3gpbwlzabwcc3nbd7nqb4kb4i0sls")))) "0n39s1i88j6s7vvsdhpbhcr3gpbwlzabwcc3nbd7nqb4kb4i0sls"))))
(build-system haskell-build-system) (build-system haskell-build-system)
(arguments
`(#:configure-flags (list "--allow-newer=QuickCheck")))
(inputs (inputs
`(("ghc-hashable" ,ghc-hashable))) `(("ghc-hashable" ,ghc-hashable)))
(native-inputs (native-inputs
@ -9518,4 +9658,24 @@ serialization code.")
(home-page "https://hackage.haskell.org/package/bytes") (home-page "https://hackage.haskell.org/package/bytes")
(license license:bsd-3))) (license license:bsd-3)))
(define-public ghc-disk-free-space
(package
(name "ghc-disk-free-space")
(version "0.1.0.1")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"disk-free-space/disk-free-space-"
version ".tar.gz"))
(sha256
(base32
"07rqj8k1vh3cykq9yidpjxhgh1f7vgmjs6y1nv5kq2217ff4yypi"))))
(build-system haskell-build-system)
(home-page "https://github.com/redneb/disk-free-space")
(synopsis "Retrieve information about disk space usage")
(description "A cross-platform library for retrieving information about
disk space usage.")
(license license:bsd-3)))
;;; haskell.scm ends here ;;; haskell.scm ends here

4
gnu/packages/messaging.scm
View File

@ -736,14 +736,14 @@ a graphical desktop environment like GNOME.")
(define-public prosody (define-public prosody
(package (package
(name "prosody") (name "prosody")
(version "0.10.1") (version "0.10.2")
(source (origin (source (origin
(method url-fetch) (method url-fetch)
(uri (string-append "https://prosody.im/downloads/source/" (uri (string-append "https://prosody.im/downloads/source/"
"prosody-" version ".tar.gz")) "prosody-" version ".tar.gz"))
(sha256 (sha256
(base32 (base32
"1kmmpkkgymg1r8r0k8j83pgmiskg1phl8hmpzjrnvlvsfnrnjplr")))) "13knr7izscw0zx648b9582dx11aap4cq9bzfiqh5ykd7wwsz1dbm"))))
(build-system gnu-build-system) (build-system gnu-build-system)
(arguments (arguments
`(#:tests? #f ; no "check" target `(#:tests? #f ; no "check" target

28
gnu/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch Normal file
View File

@ -0,0 +1,28 @@
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 2efc649..8903b52 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -93,7 +95,7 @@
find_package(XKB REQUIRED)
# Qt 5
-find_package(Qt5 5.6.0 CONFIG REQUIRED Core DBus Gui Qml Quick LinguistTools)
+find_package(Qt5 5.8.0 CONFIG REQUIRED Core DBus Gui Qml Quick LinguistTools Test)
# find qt5 imports dir
get_target_property(QMAKE_EXECUTABLE Qt5::qmake LOCATION)
diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt
index c9d935a..bb85ddd 100644
--- a/test/CMakeLists.txt
+++ b/test/CMakeLists.txt
@@ -2,9 +2,8 @@
include_directories(../src/common)
-
set(ConfigurationTest_SRCS ConfigurationTest.cpp ../src/common/ConfigReader.cpp)
add_executable(ConfigurationTest ${ConfigurationTest_SRCS})
add_test(NAME Configuration COMMAND ConfigurationTest)
-qt5_use_modules(ConfigurationTest Test)
+target_link_libraries(ConfigurationTest Qt5::Core Qt5::Test)

23
gnu/packages/python.scm
View File

@ -5243,6 +5243,29 @@ more advanced mathematics.")
(define-public python2-mpmath (define-public python2-mpmath
(package-with-python2 python-mpmath)) (package-with-python2 python-mpmath))
(define-public python-bigfloat
(package
(name "python-bigfloat")
(version "0.3.0")
(source
(origin
(method url-fetch)
(uri (pypi-uri "bigfloat" version))
(sha256
(base32 "0xd7q4l7v0f463diznjv4k9wlaks80pn9drdqmfifi7zx8qvybi6"))))
(build-system python-build-system)
(inputs
`(("mpfr" ,mpfr)))
(home-page "https://github.com/mdickinson/bigfloat")
(synopsis "Arbitrary precision floating-point arithmetic for Python")
(description
"This packages provides a Python interface to the MPFR library for
multiprecision arithmetic.")
(license license:lgpl3+)))
(define-public python2-bigfloat
(package-with-python2 python-bigfloat))
(define-public python-sympy (define-public python-sympy
(package (package
(name "python-sympy") (name "python-sympy")

10
gnu/packages/qt.scm
View File

@ -489,6 +489,16 @@ developers using C++ or QML, a CSS & JavaScript like language.")
out "/share/doc/qt5/examples") out "/share/doc/qt5/examples")
"-opensource" "-opensource"
"-confirm-license" "-confirm-license"
;; These features require higher versions of Linux than the
;; minimum version of the glibc. See
;; src/corelib/global/minimum-linux_p.h. By disabling these
;; features Qt5 applications can be used on the oldest
;; kernels that the glibc supports, including the RHEL6
;; (2.6.32) and RHEL7 (3.10) kernels.
"-no-feature-getentropy" ; requires Linux 3.17
"-no-feature-renameat2" ; requires Linux 3.16
;; Do not build examples; if desired, these could go ;; Do not build examples; if desired, these could go
;; into a separate output, but for the time being, we ;; into a separate output, but for the time being, we
;; prefer to save the space and build time. ;; prefer to save the space and build time.

62
gnu/packages/rust.scm
View File

@ -63,32 +63,34 @@
(package (package
(name "rust-bootstrap") (name "rust-bootstrap")
(version "1.22.1") (version "1.22.1")
(source (origin (source #f)
(method url-fetch)
(uri (string-append
"https://static.rust-lang.org/dist/"
"rust-" version "-" %host-type ".tar.gz"))
(sha256
(base32
(match %host-type
("i686-unknown-linux-gnu"
"15zqbx86nm13d5vq2gm69b7av4vg479f74b5by64hs3bcwwm08pr")
("x86_64-unknown-linux-gnu"
"1yll78x6b3abnvgjf2b66gvp6mmcb9y9jdiqcwhmgc0z0i0fix4c")
("armv7-unknown-linux-gnueabihf"
"138a8l528kzp5wyk1mgjaxs304ac5ms8vlpq0ggjaznm6bn2j7a5")
("aarch64-unknown-linux-gnu"
"0z6m9m1rx4d96nvybbfmpscq4dv616m615ijy16d5wh2vx0p4na8")
("mips64el-unknown-linux-gnuabi64"
"07k4pcv7jvfa48cscdj8752lby7m7xdl88v3a6na1vs675lhgja2")
(_ ""))))))
(build-system gnu-build-system) (build-system gnu-build-system)
(native-inputs (native-inputs
`(("patchelf" ,patchelf))) `(("patchelf" ,patchelf)))
(inputs (inputs
`(("gcc" ,(canonical-package gcc)) `(("gcc" ,(canonical-package gcc))
("gcc:lib" ,(canonical-package gcc) "lib") ("gcc:lib" ,(canonical-package gcc) "lib")
("zlib" ,zlib))) ("zlib" ,zlib)
("source"
,(origin
(method url-fetch)
(uri (string-append
"https://static.rust-lang.org/dist/"
"rust-" version "-" (nix-system->gnu-triplet) ".tar.gz"))
(sha256
(base32
(match (nix-system->gnu-triplet)
("i686-unknown-linux-gnu"
"15zqbx86nm13d5vq2gm69b7av4vg479f74b5by64hs3bcwwm08pr")
("x86_64-unknown-linux-gnu"
"1yll78x6b3abnvgjf2b66gvp6mmcb9y9jdiqcwhmgc0z0i0fix4c")
("armv7-unknown-linux-gnueabihf"
"138a8l528kzp5wyk1mgjaxs304ac5ms8vlpq0ggjaznm6bn2j7a5")
("aarch64-unknown-linux-gnu"
"0z6m9m1rx4d96nvybbfmpscq4dv616m615ijy16d5wh2vx0p4na8")
("mips64el-unknown-linux-gnuabi64"
"07k4pcv7jvfa48cscdj8752lby7m7xdl88v3a6na1vs675lhgja2")
(_ ""))))))))
(outputs '("out" "cargo")) (outputs '("out" "cargo"))
(arguments (arguments
`(#:tests? #f `(#:tests? #f
@ -117,7 +119,7 @@
(invoke "bash" "install.sh" (invoke "bash" "install.sh"
(string-append "--prefix=" out) (string-append "--prefix=" out)
(string-append "--components=rustc," (string-append "--components=rustc,"
"rust-std-" %host-type)) "rust-std-" ,(nix-system->gnu-triplet)))
;; Instal cargo ;; Instal cargo
(invoke "bash" "install.sh" (invoke "bash" "install.sh"
(string-append "--prefix=" cargo-out) (string-append "--prefix=" cargo-out)
@ -196,6 +198,12 @@ in turn be used to build the final Rust.")
;; This test is known to fail on aarch64 and powerpc64le: ;; This test is known to fail on aarch64 and powerpc64le:
;; https://github.com/rust-lang/rust/issues/45410 ;; https://github.com/rust-lang/rust/issues/45410
(("fn test_loading_cosine") "#[ignore]\nfn test_loading_cosine")) (("fn test_loading_cosine") "#[ignore]\nfn test_loading_cosine"))
;; nm doesn't recognize the file format because of the
;; nonstandard sections used by the Rust compiler, but readelf
;; ignores them.
(substitute* "src/test/run-make/atomic-lock-free/Makefile"
(("\tnm ")
"\treadelf -c "))
#t))) #t)))
(add-after 'patch-source-shebangs 'patch-cargo-checksums (add-after 'patch-source-shebangs 'patch-cargo-checksums
(lambda* _ (lambda* _
@ -386,6 +394,10 @@ safety and thread safety guarantees.")
(substitute* "src/tools/cargo/tests/death.rs" (substitute* "src/tools/cargo/tests/death.rs"
;; This is stuck when built in container. ;; This is stuck when built in container.
(("fn ctrl_c_kills_everyone") "#[ignore]\nfn ctrl_c_kills_everyone")) (("fn ctrl_c_kills_everyone") "#[ignore]\nfn ctrl_c_kills_everyone"))
;; Prints test output in the wrong order when built on
;; i686-linux.
(substitute* "src/tools/cargo/tests/test.rs"
(("fn cargo_test_env") "#[ignore]\nfn cargo_test_env"))
#t)) #t))
(add-after 'patch-cargo-tests 'fix-mtime-bug (add-after 'patch-cargo-tests 'fix-mtime-bug
(lambda* _ (lambda* _
@ -433,7 +445,7 @@ rpath = true
# codegen/mainsubprogram.rs and codegen/mainsubprogramstart.rs # codegen/mainsubprogram.rs and codegen/mainsubprogramstart.rs
# This tests required patched LLVM # This tests required patched LLVM
codegen-tests = false codegen-tests = false
[target." %host-type "] [target." ,(nix-system->gnu-triplet) "]
llvm-config = \"" llvm "/bin/llvm-config" "\" llvm-config = \"" llvm "/bin/llvm-config" "\"
cc = \"" gcc "/bin/gcc" "\" cc = \"" gcc "/bin/gcc" "\"
cxx = \"" gcc "/bin/g++" "\" cxx = \"" gcc "/bin/g++" "\"
@ -456,8 +468,10 @@ jemalloc = \"" jemalloc "/lib/libjemalloc_pic.a" "\"
(invoke "./x.py" "build" "src/tools/cargo"))) (invoke "./x.py" "build" "src/tools/cargo")))
(replace 'check (replace 'check
(lambda* _ (lambda* _
(invoke "./x.py" "test") ;; Disable parallel execution to prevent EAGAIN errors when
(invoke "./x.py" "test" "src/tools/cargo"))) ;; running tests.
(invoke "./x.py" "-j1" "test")
(invoke "./x.py" "-j1" "test" "src/tools/cargo")))
(replace 'install (replace 'install
(lambda* (#:key outputs #:allow-other-keys) (lambda* (#:key outputs #:allow-other-keys)
(invoke "./x.py" "install") (invoke "./x.py" "install")

129
gnu/packages/version-control.scm
View File

@ -20,6 +20,7 @@
;;; Copyright © 2017 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2017 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2018 Sou Bunnbu <iyzsong@member.fsf.org> ;;; Copyright © 2018 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2018 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -84,6 +85,7 @@
#:use-module (gnu packages python) #:use-module (gnu packages python)
#:use-module (gnu packages python-web) #:use-module (gnu packages python-web)
#:use-module (gnu packages readline) #:use-module (gnu packages readline)
#:use-module (gnu packages rsync)
#:use-module (gnu packages databases) #:use-module (gnu packages databases)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages xml) #:use-module (gnu packages xml)
@ -1993,3 +1995,130 @@ venerable RCS, hence the anagrammatic acronym. The design is tuned for use
cases like all those little scripts in your @file{~/bin} directory, or a cases like all those little scripts in your @file{~/bin} directory, or a
directory full of HOWTOs.") directory full of HOWTOs.")
(license license:bsd-2))) (license license:bsd-2)))
(define-public git-annex
(package
(name "git-annex")
(version "6.20170818")
(source
(origin
(method url-fetch)
(uri (string-append "https://hackage.haskell.org/package/"
"git-annex/git-annex-" version ".tar.gz"))
(sha256
(base32
"0ybxixbqvy4rx6mq9s02rh349rbr04hb17z4bfayin0qwa5kzpvx"))))
(build-system haskell-build-system)
(arguments
`(#:configure-flags
'("--flags=-Android -Assistant -Pairing -S3 -Webapp -WebDAV")
#:phases
(modify-phases %standard-phases
(add-before 'configure 'patch-shell
(lambda _
(substitute* "Utility/Shell.hs"
(("/bin/sh") (which "sh")))
#t))
(add-before 'configure 'factor-setup
(lambda _
;; Factor out necessary build logic from the provided
;; `Setup.hs' script. The script as-is does not work because
;; it cannot find its dependencies, and there is no obvious way
;; to tell it where to look. Note that we do not preserve the
;; code that installs man pages here.
(call-with-output-file "PreConf.hs"
(lambda (out)
(format out "import qualified Build.Configure as Configure~%")
(format out "main = Configure.run Configure.tests~%")))
(call-with-output-file "Setup.hs"
(lambda (out)
(format out "import Distribution.Simple~%")
(format out "main = defaultMain~%")))
#t))
(add-before 'configure 'pre-configure
(lambda _
(invoke "runhaskell" "PreConf.hs")
#t))
(replace 'check
(lambda _
;; We need to set the path so that Git recognizes
;; `git annex' as a custom command.
(setenv "PATH" (string-append (getenv "PATH") ":"
(getcwd) "/dist/build/git-annex"))
(with-directory-excursion "dist/build/git-annex"
(symlink "git-annex" "git-annex-shell"))
(invoke "git-annex" "test")
#t))
(add-after 'install 'install-symlinks
(lambda* (#:key outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(bin (string-append out "/bin")))
(symlink (string-append bin "/git-annex")
(string-append bin "/git-annex-shell"))
(symlink (string-append bin "/git-annex")
(string-append bin "/git-remote-tor-annex"))
#t))))))
(inputs
`(("curl" ,curl)
("ghc-aeson" ,ghc-aeson)
("ghc-async" ,ghc-async)
("ghc-bloomfilter" ,ghc-bloomfilter)
("ghc-byteable" ,ghc-byteable)
("ghc-case-insensitive" ,ghc-case-insensitive)
("ghc-crypto-api" ,ghc-crypto-api)
("ghc-cryptonite" ,ghc-cryptonite)
("ghc-data-default" ,ghc-data-default)
("ghc-disk-free-space" ,ghc-disk-free-space)
("ghc-dlist" ,ghc-dlist)
("ghc-edit-distance" ,ghc-edit-distance)
("ghc-esqueleto" ,ghc-esqueleto)
("ghc-exceptions" ,ghc-exceptions)
("ghc-feed" ,ghc-feed)
("ghc-free" ,ghc-free)
("ghc-hslogger" ,ghc-hslogger)
("ghc-http-client" ,ghc-http-client)
("ghc-http-conduit" ,ghc-http-conduit)
("ghc-http-types" ,ghc-http-types)
("ghc-ifelse" ,ghc-ifelse)
("ghc-memory" ,ghc-memory)
("ghc-monad-control" ,ghc-monad-control)
("ghc-monad-logger" ,ghc-monad-logger)
("ghc-mtl" ,ghc-mtl)
("ghc-network" ,ghc-network)
("ghc-old-locale" ,ghc-old-locale)
("ghc-optparse-applicative" ,ghc-optparse-applicative)
("ghc-persistent" ,ghc-persistent)
("ghc-persistent-sqlite" ,ghc-persistent-sqlite)
("ghc-persistent-template" ,ghc-persistent-template)
("ghc-quickcheck" ,ghc-quickcheck)
("ghc-random" ,ghc-random)
("ghc-regex-tdfa" ,ghc-regex-tdfa)
("ghc-resourcet" ,ghc-resourcet)
("ghc-safesemaphore" ,ghc-safesemaphore)
("ghc-sandi" ,ghc-sandi)
("ghc-securemem" ,ghc-securemem)
("ghc-socks" ,ghc-socks)
("ghc-split" ,ghc-split)
("ghc-stm" ,ghc-stm)
("ghc-stm-chans" ,ghc-stm-chans)
("ghc-text" ,ghc-text)
("ghc-unix-compat" ,ghc-unix-compat)
("ghc-unordered-containers" ,ghc-unordered-containers)
("ghc-utf8-string" ,ghc-utf8-string)
("ghc-uuid" ,ghc-uuid)
("git" ,git)
("rsync" ,rsync)))
(native-inputs
`(("ghc-tasty" ,ghc-tasty)
("ghc-tasty-hunit" ,ghc-tasty-hunit)
("ghc-tasty-quickcheck" ,ghc-tasty-quickcheck)
("ghc-tasty-rerun" ,ghc-tasty-rerun)))
(home-page "https://git-annex.branchable.com/")
(synopsis "Manage files with Git, without checking in their contents")
(description "This package allows managing files with Git, without
checking the file contents into Git. It can store files in many places,
such as local hard drives and cloud storage services. It can also be
used to keep a folder in sync between computers.")
;; The web app is released under the AGPLv3+.
(license (list license:gpl3+
license:agpl3+))))

81
gnu/packages/web.scm
View File

@ -25,6 +25,7 @@
;;; Copyright © 2017 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2017 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2017 Rutger Helling <rhelling@mykolab.com> ;;; Copyright © 2017 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -82,6 +83,7 @@
#:use-module (gnu packages gnuzilla) #:use-module (gnu packages gnuzilla)
#:use-module (gnu packages gperf) #:use-module (gnu packages gperf)
#:use-module (gnu packages gtk) #:use-module (gnu packages gtk)
#:use-module (gnu packages guile)
#:use-module (gnu packages java) #:use-module (gnu packages java)
#:use-module (gnu packages javascript) #:use-module (gnu packages javascript)
#:use-module (gnu packages jemalloc) #:use-module (gnu packages jemalloc)
@ -96,6 +98,7 @@
#:use-module (gnu packages ncurses) #:use-module (gnu packages ncurses)
#:use-module (gnu packages openstack) #:use-module (gnu packages openstack)
#:use-module (gnu packages base) #:use-module (gnu packages base)
#:use-module (gnu packages package-management)
#:use-module (gnu packages perl) #:use-module (gnu packages perl)
#:use-module (gnu packages perl-check) #:use-module (gnu packages perl-check)
#:use-module (gnu packages python) #:use-module (gnu packages python)
@ -6424,3 +6427,81 @@ compressed JSON header blocks.
@item @command{inflatehd} converts such compressed headers back to JSON pairs. @item @command{inflatehd} converts such compressed headers back to JSON pairs.
@end itemize\n") @end itemize\n")
(license l:expat))) (license l:expat)))
(define-public hpcguix-web
(let ((commit "3e3b9a3a406ee2dcd10c96cbedcc16ea378e8e8f"))
(package
(name "hpcguix-web")
(version (git-version "0.0.1" "0" commit))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/UMCUGenetics/hpcguix-web.git")
(commit commit)))
(file-name (git-file-name name version))
(sha256
(base32
"01888byi9mh7d3adcmwhmg44kg98g92r44ilc4wd7an66mjnxpry"))))
(build-system gnu-build-system)
(arguments
`(#:modules ((guix build gnu-build-system)
(guix build utils)
(srfi srfi-26)
(ice-9 popen)
(ice-9 rdelim))
#:phases
(modify-phases %standard-phases
(add-before 'configure 'autoconf
(lambda _
(setenv "GUILE_AUTO_COMPILE" "0")
(setenv "XDG_CACHE_HOME" (getcwd))
(invoke "autoreconf" "-vif")))
(add-after 'install 'wrap-program
(lambda* (#:key inputs outputs #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(guix (assoc-ref inputs "guix"))
(guile (assoc-ref inputs "guile"))
(json (assoc-ref inputs "guile-json"))
(guile-cm (assoc-ref inputs
"guile-commonmark"))
(deps (list guile guile-cm guix json))
(effective
(read-line
(open-pipe* OPEN_READ
(string-append guile "/bin/guile")
"-c" "(display (effective-version))")))
(path (string-join
(map (cut string-append <>
"/share/guile/site/"
effective)
deps)
":"))
(gopath (string-join
(map (cut string-append <>
"/lib/guile/" effective
"/site-ccache")
deps)
":")))
(wrap-program (string-append out "/bin/run")
`("GUILE_LOAD_PATH" ":" prefix (,path))
`("GUILE_LOAD_COMPILED_PATH" ":" prefix (,gopath)))
#t))))))
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
("uglify-js" ,uglify-js)
("pkg-config" ,pkg-config)))
(inputs
`(("guix" ,guix)))
(propagated-inputs
`(("guile" ,guile-2.2)
("guile-commonmark" ,guile-commonmark)
("guile-json" ,guile-json)))
(home-page "https://github.com/UMCUGenetics/hpcguix-web")
(synopsis "Web interface for cluster deployments of Guix")
(description "Hpcguix-web provides a web interface to the list of packages
provided by Guix. The list of packages is searchable and provides
instructions on how to use Guix in a shared HPC environment.")
(license l:agpl3+))))

72
gnu/services/web.scm
View File

@ -6,6 +6,7 @@
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2017 nee <nee-git@hidamari.blue> ;;; Copyright © 2017 nee <nee-git@hidamari.blue>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -25,11 +26,14 @@
(define-module (gnu services web) (define-module (gnu services web)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module (gnu system pam)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
#:use-module (gnu packages web) #:use-module (gnu packages web)
#:use-module (gnu packages php) #:use-module (gnu packages php)
#:use-module (gnu packages guile)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix modules)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module ((guix utils) #:select (version-major)) #:use-module ((guix utils) #:select (version-major))
#:use-module ((guix packages) #:select (package-version)) #:use-module ((guix packages) #:select (package-version))
@ -155,7 +159,11 @@
php-fpm-service-type php-fpm-service-type
nginx-php-location nginx-php-location
cat-avatar-generator-service)) cat-avatar-generator-service
hpcguix-web-configuration
hpcguix-web-configuration?
hpcguix-web-service-type))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -893,3 +901,65 @@ a webserver.")
(nginx-server-configuration-locations configuration))) (nginx-server-configuration-locations configuration)))
(root #~(string-append #$package (root #~(string-append #$package
"/share/web/cat-avatar-generator")))))) "/share/web/cat-avatar-generator"))))))
(define-record-type* <hpcguix-web-configuration>
hpcguix-web-configuration make-hpcguix-web-configuration
hpcguix-web-configuration?
(package hpcguix-web-package (default hpcguix-web)) ;<package>
;; Specs is gexp of hpcguix-web configuration file
(specs hpcguix-web-configuration-specs))
(define %hpcguix-web-accounts
(list (user-group
(name "hpcguix-web")
(system? #t))
(user-account
(name "hpcguix-web")
(group "hpcguix-web")
(system? #t)
(comment "hpcguix-web")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define %hpcguix-web-activation
#~(begin
(use-modules (guix build utils))
(let ((home-dir "/var/cache/guix/web")
(user (getpwnam "hpcguix-web")))
(mkdir-p home-dir)
(chown home-dir (passwd:uid user) (passwd:gid user))
(chmod home-dir #o755))))
(define (hpcguix-web-shepherd-service config)
(let ((specs (hpcguix-web-configuration-specs config))
(hpcguix-web (hpcguix-web-package config)))
(with-imported-modules (source-module-closure
'((gnu build shepherd)))
(shepherd-service
(documentation "hpcguix-web daemon")
(provision '(hpcguix-web))
(requirement '(networking))
(start #~(make-forkexec-constructor
(list #$(file-append hpcguix-web "/bin/run")
(string-append "--config="
#$(scheme-file "hpcguix-web.scm" specs)))
#:user "hpcguix-web"
#:group "hpcguix-web"
#:environment-variables
(list "XDG_CACHE_HOME=/var/cache")))
(stop #~(make-kill-destructor))))))
(define hpcguix-web-service-type
(service-type
(name 'hpcguix-web)
(description "Run the hpcguix-web server.")
(extensions
(list (service-extension account-service-type
(const %hpcguix-web-accounts))
(service-extension activation-service-type
(const %hpcguix-web-activation))
(service-extension shepherd-root-service-type
(compose list hpcguix-web-shepherd-service))))))

4
gnu/system.scm
View File

@ -317,8 +317,8 @@ file system labels."
(_ ;the old format (_ ;the old format
"/"))))) "/")))))
(x ;unsupported format (x ;unsupported format
(warning (G_ "unrecognized boot parameters for '~a'~%") (warning (G_ "unrecognized boot parameters at '~a'~%")
system) (port-filename port))
#f))) #f)))
(define (read-boot-parameters-file system) (define (read-boot-parameters-file system)

93
gnu/system/vm.scm
View File

@ -410,58 +410,57 @@ should set REGISTER-CLOSURES? to #f."
(eval-when (expand load eval) (eval-when (expand load eval)
(define %libgcrypt (define %libgcrypt
#+(file-append libgcrypt "/lib/libgcrypt")))))) #+(file-append libgcrypt "/lib/libgcrypt"))))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz")) (name -> (string-append name ".tar.gz"))
(graph -> "system-graph")) (graph -> "system-graph"))
(define build (define build
(with-imported-modules `(,@(source-module-closure '((guix docker) (with-extensions (list guile-json) ;for (guix docker)
(guix build utils) (with-imported-modules `(,@(source-module-closure
(gnu build vm)) '((guix docker)
#:select? not-config?) (guix build utils)
(guix build store-copy) (gnu build vm))
((guix config) => ,config)) #:select? not-config?)
#~(begin (guix build store-copy)
;; Guile-JSON is required by (guix docker). ((guix config) => ,config))
(add-to-load-path #~(begin
(string-append #+guile-json "/share/guile/site/" (use-modules (guix docker)
(effective-version))) (guix build utils)
(use-modules (guix docker) (gnu build vm)
(guix build utils) (srfi srfi-19)
(gnu build vm) (guix build store-copy))
(srfi srfi-19)
(guix build store-copy))
(let* ((inputs '#$(append (list tar) (let* ((inputs '#$(append (list tar)
(if register-closures? (if register-closures?
(list guix) (list guix)
'()))) '())))
;; This initializer requires elevated privileges that are ;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g., ;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain ;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM. ;; such privileges, we run it as root in a VM.
(initialize (root-partition-initializer (initialize (root-partition-initializer
#:closures '(#$graph) #:closures '(#$graph)
#:register-closures? #$register-closures? #:register-closures? #$register-closures?
#:system-directory #$os-drv #:system-directory #$os-drv
;; De-duplication would fail due to ;; De-duplication would fail due to
;; cross-device link errors, so don't do it. ;; cross-device link errors, so don't do it.
#:deduplicate? #f)) #:deduplicate? #f))
;; Even as root in a VM, the initializer would fail due to ;; Even as root in a VM, the initializer would fail due to
;; lack of privileges if we use a root-directory that is on ;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp). ;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root")) (root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(mkdir root-directory) (mkdir root-directory)
(initialize root-directory) (initialize root-directory)
(build-docker-image (build-docker-image
(string-append "/xchg/" #$name) ;; The output file. (string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory (cons* root-directory
(call-with-input-file (string-append "/xchg/" #$graph) (call-with-input-file (string-append "/xchg/" #$graph)
read-reference-graph)) read-reference-graph))
#$os-drv #$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1) #:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> ""))))))) #:transformations `((,root-directory -> ""))))))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp

19
gnu/tests/dict.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -96,22 +96,7 @@
;; Wait until dicod is actually listening. ;; Wait until dicod is actually listening.
;; TODO: Use a PID file instead. ;; TODO: Use a PID file instead.
(test-assert "connect inside" (test-assert "connect inside"
(marionette-eval (wait-for-tcp-port 2628 marionette))
'(begin
(use-modules (ice-9 rdelim))
(let ((sock (socket PF_INET SOCK_STREAM 0)))
(let loop ((i 0))
(pk 'try i)
(catch 'system-error
(lambda ()
(connect sock AF_INET INADDR_LOOPBACK 2628))
(lambda args
(pk 'connection-error args)
(when (< i 20)
(sleep 1)
(loop (+ 1 i))))))
(read-line sock 'concat)))
marionette))
(test-assert "connect" (test-assert "connect"
(let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000))) (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000)))

262
gnu/tests/ssh.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; ;;;
@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test."
(define test (define test
(with-imported-modules '((gnu build marionette)) (with-imported-modules '((gnu build marionette))
#~(begin (with-extensions (list guile-ssh)
(eval-when (expand load eval) #~(begin
;; Prepare to use Guile-SSH. (use-modules (gnu build marionette)
(set! %load-path (srfi srfi-26)
(cons (string-append #+guile-ssh "/share/guile/site/" (srfi srfi-64)
(effective-version)) (ice-9 match)
%load-path))) (ssh session)
(ssh auth)
(ssh channel)
(ssh sftp))
(use-modules (gnu build marionette) (define marionette
(srfi srfi-26) ;; Enable TCP forwarding of the guest's port 22.
(srfi srfi-64) (make-marionette (list #$vm)))
(ice-9 match)
(ssh session)
(ssh auth)
(ssh channel)
(ssh sftp))
(define marionette (define (make-session-for-test)
;; Enable TCP forwarding of the guest's port 22. "Make a session with predefined parameters for a test."
(make-marionette (list #$vm))) (make-session #:user "root"
#:port 2222
#:host "localhost"
#:log-verbosity 'protocol))
(define (make-session-for-test) (define (call-with-connected-session proc)
"Make a session with predefined parameters for a test." "Call the one-argument procedure PROC with a freshly created and
(make-session #:user "root"
#:port 2222
#:host "localhost"
#:log-verbosity 'protocol))
(define (call-with-connected-session proc)
"Call the one-argument procedure PROC with a freshly created and
connected SSH session object, return the result of the procedure call. The connected SSH session object, return the result of the procedure call. The
session is disconnected when the PROC is finished." session is disconnected when the PROC is finished."
(let ((session (make-session-for-test))) (let ((session (make-session-for-test)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(let ((result (connect! session))) (let ((result (connect! session)))
(unless (equal? result 'ok) (unless (equal? result 'ok)
(error "Could not connect to a server" (error "Could not connect to a server"
session result)))) session result))))
(lambda () (proc session)) (lambda () (proc session))
(lambda () (disconnect! session))))) (lambda () (disconnect! session)))))
(define (call-with-connected-session/auth proc) (define (call-with-connected-session/auth proc)
"Make an authenticated session. We should be able to connect as "Make an authenticated session. We should be able to connect as
root with an empty password." root with an empty password."
(call-with-connected-session (call-with-connected-session
(lambda (session) (lambda (session)
;; Try the simple authentication methods. Dropbear requires ;; Try the simple authentication methods. Dropbear requires
;; 'none' when there are no passwords, whereas OpenSSH accepts ;; 'none' when there are no passwords, whereas OpenSSH accepts
;; 'password' with an empty password. ;; 'password' with an empty password.
(let loop ((methods (list (cut userauth-password! <> "") (let loop ((methods (list (cut userauth-password! <> "")
(cut userauth-none! <>)))) (cut userauth-none! <>))))
(match methods (match methods
(() (()
(error "all the authentication methods failed")) (error "all the authentication methods failed"))
((auth rest ...) ((auth rest ...)
(match (pk 'auth (auth session)) (match (pk 'auth (auth session))
('success ('success
(proc session)) (proc session))
('denied ('denied
(loop rest))))))))) (loop rest)))))))))
(mkdir #$output) (mkdir #$output)
(chdir #$output) (chdir #$output)
(test-begin "ssh-daemon") (test-begin "ssh-daemon")
;; Wait for sshd to be up and running. ;; Wait for sshd to be up and running.
(test-eq "service running" (test-eq "service running"
'running! 'running!
(marionette-eval (marionette-eval
'(begin '(begin
(use-modules (gnu services herd)) (use-modules (gnu services herd))
(start-service 'ssh-daemon) (start-service 'ssh-daemon)
'running!) 'running!)
marionette)) marionette))
;; Check sshd's PID file. ;; Check sshd's PID file.
(test-equal "sshd PID" (test-equal "sshd PID"
(wait-for-file #$pid-file marionette) (wait-for-file #$pid-file marionette)
(marionette-eval (marionette-eval
'(begin '(begin
(use-modules (gnu services herd) (use-modules (gnu services herd)
(srfi srfi-1)) (srfi srfi-1))
(live-service-running (live-service-running
(find (lambda (live) (find (lambda (live)
(memq 'ssh-daemon (memq 'ssh-daemon
(live-service-provision live))) (live-service-provision live)))
(current-services)))) (current-services))))
marionette)) marionette))
;; Connect to the guest over SSH. Make sure we can run a shell ;; Connect to the guest over SSH. Make sure we can run a shell
;; command there. ;; command there.
(test-equal "shell command" (test-equal "shell command"
'hello 'hello
(call-with-connected-session/auth (call-with-connected-session/auth
(lambda (session) (lambda (session)
;; FIXME: 'get-server-public-key' segfaults. ;; FIXME: 'get-server-public-key' segfaults.
;; (get-server-public-key session) ;; (get-server-public-key session)
(let ((channel (make-channel session))) (let ((channel (make-channel session)))
(channel-open-session channel) (channel-open-session channel)
(channel-request-exec channel "echo hello > /root/witness") (channel-request-exec channel "echo hello > /root/witness")
(and (zero? (channel-get-exit-status channel)) (and (zero? (channel-get-exit-status channel))
(wait-for-file "/root/witness" marionette)))))) (wait-for-file "/root/witness" marionette))))))
;; Connect to the guest over SFTP. Make sure we can write and ;; Connect to the guest over SFTP. Make sure we can write and
;; read a file there. ;; read a file there.
(unless #$sftp? (unless #$sftp?
(test-skip 1)) (test-skip 1))
(test-equal "SFTP file writing and reading" (test-equal "SFTP file writing and reading"
'hello 'hello
(call-with-connected-session/auth (call-with-connected-session/auth
(lambda (session) (lambda (session)
(let ((sftp-session (make-sftp-session session)) (let ((sftp-session (make-sftp-session session))
(witness "/root/sftp-witness")) (witness "/root/sftp-witness"))
(call-with-remote-output-file sftp-session witness (call-with-remote-output-file sftp-session witness
(cut display "hello" <>)) (cut display "hello" <>))
(call-with-remote-input-file sftp-session witness (call-with-remote-input-file sftp-session witness
read))))) read)))))
;; Connect to the guest over SSH. Make sure we can run commands ;; Connect to the guest over SSH. Make sure we can run commands
;; from the system profile. ;; from the system profile.
(test-equal "run executables from system profile" (test-equal "run executables from system profile"
#t #t
(call-with-connected-session/auth (call-with-connected-session/auth
(lambda (session) (lambda (session)
(let ((channel (make-channel session))) (let ((channel (make-channel session)))
(channel-open-session channel) (channel-open-session channel)
(channel-request-exec (channel-request-exec
channel channel
(string-append (string-append
"mkdir -p /root/.guix-profile/bin && " "mkdir -p /root/.guix-profile/bin && "
"touch /root/.guix-profile/bin/path-witness && " "touch /root/.guix-profile/bin/path-witness && "
"chmod 755 /root/.guix-profile/bin/path-witness")) "chmod 755 /root/.guix-profile/bin/path-witness"))
(zero? (channel-get-exit-status channel)))))) (zero? (channel-get-exit-status channel))))))
;; Connect to the guest over SSH. Make sure we can run commands ;; Connect to the guest over SSH. Make sure we can run commands
;; from the user profile. ;; from the user profile.
(test-equal "run executable from user profile" (test-equal "run executable from user profile"
#t #t
(call-with-connected-session/auth (call-with-connected-session/auth
(lambda (session) (lambda (session)
(let ((channel (make-channel session))) (let ((channel (make-channel session)))
(channel-open-session channel) (channel-open-session channel)
(channel-request-exec channel "path-witness") (channel-request-exec channel "path-witness")
(zero? (channel-get-exit-status channel)))))) (zero? (channel-get-exit-status channel))))))
(test-end) (test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))) (exit (= (test-runner-fail-count (test-runner-current)) 0))))))
(gexp->derivation name test)) (gexp->derivation name test))

82
gnu/tests/web.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -31,7 +32,8 @@
#:use-module (guix store) #:use-module (guix store)
#:export (%test-httpd #:export (%test-httpd
%test-nginx %test-nginx
%test-php-fpm)) %test-php-fpm
%test-hpcguix-web))
(define %index.html-contents (define %index.html-contents
;; Contents of the /index.html file. ;; Contents of the /index.html file.
@ -281,3 +283,81 @@ HTTP-PORT, along with php-fpm."
(name "php-fpm") (name "php-fpm")
(description "Test PHP-FPM through nginx.") (description "Test PHP-FPM through nginx.")
(value (run-php-fpm-test)))) (value (run-php-fpm-test))))
;;;
;;; hpcguix-web
;;;
(define* (run-hpcguix-web-server-test name test-os)
"Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running."
(define os
(marionette-operating-system
test-os
#:imported-modules '((gnu services herd)
(guix combinators))))
(define vm
(virtual-machine
(operating-system os)
(port-forwardings '((8080 . 5000)))))
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
(use-modules (srfi srfi-11) (srfi srfi-64)
(gnu build marionette)
(web uri)
(web client)
(web response))
(define marionette
(make-marionette (list #$vm)))
(mkdir #$output)
(chdir #$output)
(test-begin #$name)
(test-assert "hpcguix-web running"
(marionette-eval
'(begin
(use-modules (gnu services herd))
(match (start-service 'hpcguix-web)
(#f #f)
(('service response-parts ...)
(match (assq-ref response-parts 'running)
((pid) (number? pid))))))
marionette))
(test-equal "http-get"
200
(begin
(wait-for-tcp-port 5000 marionette)
(let-values (((response text)
(http-get "http://localhost:8080")))
(response-code response))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(gexp->derivation (string-append name "-test") test))
(define %hpcguix-web-specs
;; Server config gexp.
#~(define site-config
(hpcweb-configuration
(title-prefix "[TEST] HPCGUIX-WEB"))))
(define %hpcguix-web-os
(simple-operating-system
(dhcp-client-service)
(service hpcguix-web-service-type
(hpcguix-web-configuration
(specs %hpcguix-web-specs)))))
(define %test-hpcguix-web
(system-test
(name "hpcguix-web")
(description "Connect to a running hpcguix-web server.")
(value (run-hpcguix-web-server-test name %hpcguix-web-os))))

6
guix/config.scm.in
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -29,6 +30,7 @@
%store-directory %store-directory
%state-directory %state-directory
%store-database-directory
%config-directory %config-directory
%guix-register-program %guix-register-program
@ -80,6 +82,10 @@
(or (getenv "NIX_STATE_DIR") (or (getenv "NIX_STATE_DIR")
(string-append %localstatedir "/guix"))) (string-append %localstatedir "/guix")))
(define %store-database-directory
(or (and=> (getenv "NIX_DB_DIR") canonicalize-path)
(string-append %state-directory "/db")))
(define %config-directory (define %config-directory
;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'. ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
(or (getenv "GUIX_CONFIGURATION_DIRECTORY") (or (getenv "GUIX_CONFIGURATION_DIRECTORY")

6
guix/docker.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -26,6 +26,7 @@
delete-file-recursively delete-file-recursively
with-directory-excursion with-directory-excursion
invoke)) invoke))
#:use-module (json) ;guile-json
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module ((texinfo string-utils) #:use-module ((texinfo string-utils)
@ -34,9 +35,6 @@
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (build-docker-image)) #:export (build-docker-image))
;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
(module-use! (current-module) (resolve-interface '(json)))
;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
(define docker-id (define docker-id
(compose bytevector->base16-string sha256 string->utf8)) (compose bytevector->base16-string sha256 string->utf8))

196
guix/gexp.scm
View File

@ -33,6 +33,7 @@
#:export (gexp #:export (gexp
gexp? gexp?
with-imported-modules with-imported-modules
with-extensions
gexp-input gexp-input
gexp-input? gexp-input?
@ -118,10 +119,11 @@
;; "G expressions". ;; "G expressions".
(define-record-type <gexp> (define-record-type <gexp>
(make-gexp references modules proc) (make-gexp references modules extensions proc)
gexp? gexp?
(references gexp-references) ;list of <gexp-input> (references gexp-references) ;list of <gexp-input>
(modules gexp-self-modules) ;list of module names (modules gexp-self-modules) ;list of module names
(extensions gexp-self-extensions) ;list of lowerable things
(proc gexp-proc)) ;procedure (proc gexp-proc)) ;procedure
(define (write-gexp gexp port) (define (write-gexp gexp port)
@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not."
(set-record-type-printer! <gexp-output> write-gexp-output) (set-record-type-printer! <gexp-output> write-gexp-output)
(define (gexp-modules gexp) (define (gexp-attribute gexp self-attribute)
"Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is "Recurse on GEXP and the expressions it refers to, summing the items
false, meaning that GEXP is a plain Scheme object, return the empty list." returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
(if (gexp? gexp) (if (gexp? gexp)
(delete-duplicates (delete-duplicates
(append (gexp-self-modules gexp) (append (self-attribute gexp)
(append-map (match-lambda (append-map (match-lambda
(($ <gexp-input> (? gexp? exp)) (($ <gexp-input> (? gexp? exp))
(gexp-modules exp)) (gexp-attribute exp self-attribute))
(($ <gexp-input> (lst ...)) (($ <gexp-input> (lst ...))
(append-map (lambda (item) (append-map (lambda (item)
(if (gexp? item) (if (gexp? item)
(gexp-modules item) (gexp-attribute item
self-attribute)
'())) '()))
lst)) lst))
(_ (_
@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
(gexp-references gexp)))) (gexp-references gexp))))
'())) ;plain Scheme data type '())) ;plain Scheme data type
(define (gexp-modules gexp)
"Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
false, meaning that GEXP is a plain Scheme object, return the empty list."
(gexp-attribute gexp gexp-self-modules))
(define (gexp-extensions gexp)
"Return the list of Guile extensions (packages) GEXP relies on. If (gexp?
GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
list."
(gexp-attribute gexp gexp-self-extensions))
(define* (lower-inputs inputs (define* (lower-inputs inputs
#:key system target) #:key system target)
"Turn any package from INPUTS into a derivation for SYSTEM; return the "Turn any package from INPUTS into a derivation for SYSTEM; return the
@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
(modules '()) (modules '())
(module-path %load-path) (module-path %load-path)
(guile-for-build (%guile-for-build)) (guile-for-build (%guile-for-build))
(effective-version "2.2")
(graft? (%graft?)) (graft? (%graft?))
references-graphs references-graphs
allowed-references disallowed-references allowed-references disallowed-references
@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
compiled, and made available in the load path during the execution of compiled, and made available in the load path during the execution of
EXP---e.g., '((guix build utils) (guix build gnu-build-system)). EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
EFFECTIVE-VERSION determines the string to use when adding extensions of
EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
GRAFT? determines whether packages referred to by EXP should be grafted when GRAFT? determines whether packages referred to by EXP should be grafted when
applicable. applicable.
@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
(define (graphs-file-names graphs) (define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
(map (match-lambda (map (match-lambda
;; TODO: Remove 'derivation?' special cases. ;; TODO: Remove 'derivation?' special cases.
((file-name (? derivation? drv)) ((file-name (? derivation? drv))
(cons file-name (derivation->output-path drv))) (cons file-name (derivation->output-path drv)))
((file-name (? derivation? drv) sub-drv) ((file-name (? derivation? drv) sub-drv)
@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing))) (cons file-name thing)))
graphs)) graphs))
(mlet* %store-monad (;; The following binding forces '%current-system' and (define (extension-flags extension)
`("-L" ,(string-append (derivation->output-path extension)
"/share/guile/site/" effective-version)
"-C" ,(string-append (derivation->output-path extension)
"/lib/guile/" effective-version "/site-ccache")))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>= ;; '%current-target-system' to be looked up at >>=
;; time. ;; time.
(graft? (set-grafting graft?)) (graft? (set-grafting graft?))
@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
#:target target)) #:target target))
(builder (text-file script-name (builder (text-file script-name
(object->string sexp))) (object->string sexp)))
(extensions -> (gexp-extensions exp))
(exts (mapm %store-monad
(lambda (obj)
(lower-object obj system))
extensions))
(modules (if (pair? %modules) (modules (if (pair? %modules)
(imported-modules %modules (imported-modules %modules
#:system system #:system system
@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
(compiled-modules %modules (compiled-modules %modules
#:system system #:system system
#:module-path module-path #:module-path module-path
#:extensions extensions
#:guile guile-for-build #:guile guile-for-build
#:deprecation-warnings #:deprecation-warnings
deprecation-warnings) deprecation-warnings)
@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
`("-L" ,(derivation->output-path modules) `("-L" ,(derivation->output-path modules)
"-C" ,(derivation->output-path compiled)) "-C" ,(derivation->output-path compiled))
'()) '())
,@(append-map extension-flags exts)
,builder) ,builder)
#:outputs outputs #:outputs outputs
#:env-vars env-vars #:env-vars env-vars
@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
,@(if modules ,@(if modules
`((,modules) (,compiled) ,@inputs) `((,modules) (,compiled) ,@inputs)
inputs) inputs)
,@(map list exts)
,@(match graphs ,@(match graphs
(((_ . inputs) ...) inputs) (((_ . inputs) ...) inputs)
(_ '()))) (_ '())))
@ -861,6 +893,17 @@ environment."
(identifier-syntax modules))) (identifier-syntax modules)))
body ...)) body ...))
(define-syntax-parameter current-imported-extensions
;; Current list of extensions.
(identifier-syntax '()))
(define-syntax-rule (with-extensions extensions body ...)
"Mark the gexps defined in BODY... as requiring EXTENSIONS in their
execution environment."
(syntax-parameterize ((current-imported-extensions
(identifier-syntax extensions)))
body ...))
(define-syntax gexp (define-syntax gexp
(lambda (s) (lambda (s)
(define (collect-escapes exp) (define (collect-escapes exp)
@ -957,6 +1000,7 @@ environment."
(refs (map escape->ref escapes))) (refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs) #`(make-gexp (list #,@refs)
current-imported-modules current-imported-modules
current-imported-extensions
(lambda #,formals (lambda #,formals
#,sexp))))))) #,sexp)))))))
@ -1071,12 +1115,21 @@ last one is created from the given <scheme-file> object."
(system (%current-system)) (system (%current-system))
(guile (%guile-for-build)) (guile (%guile-for-build))
(module-path %load-path) (module-path %load-path)
(extensions '())
(deprecation-warnings #f)) (deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files "Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other." they can refer to each other."
(define total (length modules)) (define total (length modules))
(define build-utils-hack?
;; To avoid a full rebuild, we limit the fix below to the case where
;; MODULE-PATH is different from %LOAD-PATH. This happens when building
;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make
;; this unconditional on the next rebuild cycle.
(and (member '(guix build utils) modules)
(not (equal? module-path %load-path))))
(mlet %store-monad ((modules (imported-modules modules (mlet %store-monad ((modules (imported-modules modules
#:system system #:system system
#:guile guile #:guile guile
@ -1122,7 +1175,47 @@ they can refer to each other."
(setvbuf (current-output-port) (setvbuf (current-output-port)
(cond-expand (guile-2.2 'line) (else _IOLBF))) (cond-expand (guile-2.2 'line) (else _IOLBF)))
(ungexp-splicing
(if build-utils-hack?
(gexp ((define mkdir-p
;; Capture 'mkdir-p'.
(@ (guix build utils) mkdir-p))))
'()))
;; Add EXTENSIONS to the search path.
;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
(ungexp-splicing
(if (null? extensions)
'()
(gexp ((set! %load-path
(append (map (lambda (extension)
(string-append extension
"/share/guile/site/"
(effective-version)))
'((ungexp-native-splicing extensions)))
%load-path))
(set! %load-compiled-path
(append (map (lambda (extension)
(string-append extension "/lib/guile/"
(effective-version)
"/site-ccache"))
'((ungexp-native-splicing extensions)))
%load-compiled-path))))))
(set! %load-path (cons (ungexp modules) %load-path)) (set! %load-path (cons (ungexp modules) %load-path))
(ungexp-splicing
(if build-utils-hack?
;; Above we loaded our own (guix build utils) but now we may
;; need to load a compile a different one. Thus, force a
;; reload.
(gexp ((let ((utils (ungexp
(file-append modules
"/guix/build/utils.scm"))))
(when (file-exists? utils)
(load utils)))))
'()))
(mkdir (ungexp output)) (mkdir (ungexp output))
(chdir (ungexp modules)) (chdir (ungexp modules))
(process-directory "." (ungexp output) 0)))) (process-directory "." (ungexp output) 0))))
@ -1154,20 +1247,34 @@ they can refer to each other."
(module-ref (resolve-interface '(gnu packages guile)) (module-ref (resolve-interface '(gnu packages guile))
'guile-2.2)) 'guile-2.2))
(define* (load-path-expression modules #:optional (path %load-path)) (define* (load-path-expression modules #:optional (path %load-path)
#:key (extensions '()))
"Return as a monadic value a gexp that sets '%load-path' and "Return as a monadic value a gexp that sets '%load-path' and
'%load-compiled-path' to point to MODULES, a list of module names. MODULES '%load-compiled-path' to point to MODULES, a list of module names. MODULES
are searched for in PATH." are searched for in PATH."
(mlet %store-monad ((modules (imported-modules modules (mlet %store-monad ((modules (imported-modules modules
#:module-path path)) #:module-path path))
(compiled (compiled-modules modules (compiled (compiled-modules modules
#:extensions extensions
#:module-path path))) #:module-path path)))
(return (gexp (eval-when (expand load eval) (return (gexp (eval-when (expand load eval)
(set! %load-path (set! %load-path
(cons (ungexp modules) %load-path)) (cons (ungexp modules)
(append (map (lambda (extension)
(string-append extension
"/share/guile/site/"
(effective-version)))
'((ungexp-native-splicing extensions)))
%load-path)))
(set! %load-compiled-path (set! %load-compiled-path
(cons (ungexp compiled) (cons (ungexp compiled)
%load-compiled-path))))))) (append (map (lambda (extension)
(string-append extension
"/lib/guile/"
(effective-version)
"/site-ccache"))
'((ungexp-native-splicing extensions)))
%load-compiled-path))))))))
(define* (gexp->script name exp (define* (gexp->script name exp
#:key (guile (default-guile)) #:key (guile (default-guile))
@ -1176,7 +1283,9 @@ are searched for in PATH."
imported modules in its search path. Look up EXP's modules in MODULE-PATH." imported modules in its search path. Look up EXP's modules in MODULE-PATH."
(mlet %store-monad ((set-load-path (mlet %store-monad ((set-load-path
(load-path-expression (gexp-modules exp) (load-path-expression (gexp-modules exp)
module-path))) module-path
#:extensions
(gexp-extensions exp))))
(gexp->derivation name (gexp->derivation name
(gexp (gexp
(call-with-output-file (ungexp output) (call-with-output-file (ungexp output)
@ -1205,35 +1314,38 @@ the resulting file.
When SET-LOAD-PATH? is true, emit code in the resulting file to set When SET-LOAD-PATH? is true, emit code in the resulting file to set
'%load-path' and '%load-compiled-path' to honor EXP's imported modules. '%load-path' and '%load-compiled-path' to honor EXP's imported modules.
Lookup EXP's modules in MODULE-PATH." Lookup EXP's modules in MODULE-PATH."
(match (if set-load-path? (gexp-modules exp) '()) (define modules (gexp-modules exp))
(() ;zero modules (define extensions (gexp-extensions exp))
(gexp->derivation name
(gexp (if (or (not set-load-path?)
(call-with-output-file (ungexp output) (and (null? modules) (null? extensions)))
(lambda (port) (gexp->derivation name
(for-each (lambda (exp) (gexp
(write exp port)) (call-with-output-file (ungexp output)
'(ungexp (if splice? (lambda (port)
exp (for-each (lambda (exp)
(gexp ((ungexp exp))))))))) (write exp port))
#:local-build? #t '(ungexp (if splice?
#:substitutable? #f)) exp
((modules ...) (gexp ((ungexp exp)))))))))
(mlet %store-monad ((set-load-path (load-path-expression modules #:local-build? #t
module-path))) #:substitutable? #f)
(gexp->derivation name (mlet %store-monad ((set-load-path
(gexp (load-path-expression modules module-path
(call-with-output-file (ungexp output) #:extensions extensions)))
(lambda (port) (gexp->derivation name
(write '(ungexp set-load-path) port) (gexp
(for-each (lambda (exp) (call-with-output-file (ungexp output)
(write exp port)) (lambda (port)
'(ungexp (if splice? (write '(ungexp set-load-path) port)
exp (for-each (lambda (exp)
(gexp ((ungexp exp))))))))) (write exp port))
#:module-path module-path '(ungexp (if splice?
#:local-build? #t exp
#:substitutable? #f))))) (gexp ((ungexp exp)))))))))
#:module-path module-path
#:local-build? #t
#:substitutable? #f))))
(define* (text-file* name #:rest text) (define* (text-file* name #:rest text)
"Return as a monadic value a derivation that builds a text file containing "Return as a monadic value a derivation that builds a text file containing

6
guix/man-db.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -19,6 +19,7 @@
(define-module (guix man-db) (define-module (guix man-db)
#:use-module (guix zlib) #:use-module (guix zlib)
#:use-module ((guix build utils) #:select (find-files)) #:use-module ((guix build utils) #:select (find-files))
#:use-module (gdbm) ;gdbm-ffi
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -44,9 +45,6 @@
;;; ;;;
;;; Code: ;;; Code:
;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co.
(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT))
(define-record-type <mandb-entry> (define-record-type <mandb-entry>
(mandb-entry file-name name section synopsis kind) (mandb-entry file-name name section synopsis kind)
mandb-entry? mandb-entry?

60
guix/profiles.scm
View File

@ -1196,41 +1196,39 @@ the entries in MANIFEST."
(define build (define build
(with-imported-modules modules (with-imported-modules modules
#~(begin (with-extensions (list gdbm-ffi) ;for (guix man-db)
(add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/" #~(begin
(effective-version))) (use-modules (guix man-db)
(guix build utils)
(srfi srfi-1)
(srfi srfi-19))
(use-modules (guix man-db) (define (compute-entries)
(guix build utils) (append-map (lambda (directory)
(srfi srfi-1) (let ((man (string-append directory "/share/man")))
(srfi srfi-19)) (if (directory-exists? man)
(mandb-entries man)
'())))
'#$(manifest-inputs manifest)))
(define (compute-entries) (define man-directory
(append-map (lambda (directory) (string-append #$output "/share/man"))
(let ((man (string-append directory "/share/man")))
(if (directory-exists? man)
(mandb-entries man)
'())))
'#$(manifest-inputs manifest)))
(define man-directory (mkdir-p man-directory)
(string-append #$output "/share/man"))
(mkdir-p man-directory) (format #t "Creating manual page database...~%")
(force-output)
(format #t "Creating manual page database...~%") (let* ((start (current-time))
(force-output) (entries (compute-entries))
(let* ((start (current-time)) (_ (write-mandb-database (string-append man-directory
(entries (compute-entries)) "/index.db")
(_ (write-mandb-database (string-append man-directory entries))
"/index.db") (duration (time-difference (current-time) start)))
entries)) (format #t "~a entries processed in ~,1f s~%"
(duration (time-difference (current-time) start))) (length entries)
(format #t "~a entries processed in ~,1f s~%" (+ (time-second duration)
(length entries) (* (time-nanosecond duration) (expt 10 -9))))
(+ (time-second duration) (force-output))))))
(* (time-nanosecond duration) (expt 10 -9))))
(force-output)))))
(gexp->derivation "manual-database" build (gexp->derivation "manual-database" build

31
guix/records.scm
View File

@ -63,22 +63,25 @@
(set-exception-printer! 'record-abi-mismatch-error (set-exception-printer! 'record-abi-mismatch-error
print-record-abi-mismatch-error) print-record-abi-mismatch-error)
(define (current-abi-identifier type) (eval-when (expand load eval)
"Return an identifier unhygienically derived from TYPE for use as its ;; The procedures below are needed both at run time and at expansion time.
\"current ABI\" variable."
(let ((type-name (syntax->datum type)))
(datum->syntax
type
(string->symbol
(string-append "% " (symbol->string type-name)
" abi-cookie")))))
(define (abi-check type cookie) (define (current-abi-identifier type)
"Return syntax that checks that the current \"application binary "Return an identifier unhygienically derived from TYPE for use as its
\"current ABI\" variable."
(let ((type-name (syntax->datum type)))
(datum->syntax
type
(string->symbol
(string-append "% " (symbol->string type-name)
" abi-cookie")))))
(define (abi-check type cookie)
"Return syntax that checks that the current \"application binary
interface\" (ABI) for TYPE is equal to COOKIE." interface\" (ABI) for TYPE is equal to COOKIE."
(with-syntax ((current-abi (current-abi-identifier type))) (with-syntax ((current-abi (current-abi-identifier type)))
#`(unless (eq? current-abi #,cookie) #`(unless (eq? current-abi #,cookie)
(throw 'record-abi-mismatch-error #,type)))) (throw 'record-abi-mismatch-error #,type)))))
(define-syntax make-syntactic-constructor (define-syntax make-syntactic-constructor
(syntax-rules () (syntax-rules ()

37
guix/scripts/pack.scm
View File

@ -340,28 +340,25 @@ the image."
guile-json)) guile-json))
(define build (define build
(with-imported-modules `(,@(source-module-closure '((guix docker)) ;; Guile-JSON is required by (guix docker).
#:select? not-config?) (with-extensions (list json)
(guix build store-copy) (with-imported-modules `(,@(source-module-closure '((guix docker))
((guix config) => ,config)) #:select? not-config?)
#~(begin (guix build store-copy)
;; Guile-JSON is required by (guix docker). ((guix config) => ,config))
(add-to-load-path #~(begin
(string-append #+json "/share/guile/site/" (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
(effective-version)))
(use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) (setenv "PATH" (string-append #$archiver "/bin"))
(setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output
(call-with-input-file "profile"
(build-docker-image #$output read-reference-graph)
(call-with-input-file "profile" #$profile
read-reference-graph) #:system (or #$target (utsname:machine (uname)))
#$profile #:symlinks '#$symlinks
#:system (or #$target (utsname:machine (uname))) #:compressor '#$(compressor-command compressor)
#:symlinks '#$symlinks #:creation-time (make-time time-utc 0 1))))))
#:compressor '#$(compressor-command compressor)
#:creation-time (make-time time-utc 0 1)))))
(gexp->derivation (string-append name ".tar" (gexp->derivation (string-append name ".tar"
(compressor-extension compressor)) (compressor-extension compressor))

8
guix/scripts/system.scm
View File

@ -393,9 +393,11 @@ it atomically, and then run OS's activation script."
"~Y-~m-~d ~H:~M"))) "~Y-~m-~d ~H:~M")))
(define* (profile-boot-parameters #:optional (profile %system-profile) (define* (profile-boot-parameters #:optional (profile %system-profile)
(numbers (generation-numbers profile))) (numbers
"Return a list of 'boot-parameters' for the generations of PROFILE specified by (reverse (generation-numbers profile))))
NUMBERS, which is a list of generation numbers." "Return a list of 'boot-parameters' for the generations of PROFILE specified
by NUMBERS, which is a list of generation numbers. The list is ordered from
the most recent to the oldest profiles."
(define (system->boot-parameters system number time) (define (system->boot-parameters system number time)
(unless-file-not-found (unless-file-not-found
(let* ((params (read-boot-parameters-file system)) (let* ((params (read-boot-parameters-file system))

25
guix/self.scm
View File

@ -82,6 +82,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-json" (ref '(gnu packages guile) 'guile-json))
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-git" (ref '(gnu packages guile) 'guile-git))
("guile-gdbm-ffi" (ref '(gnu packages guile) 'guile-gdbm-ffi))
("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt))
("zlib" (ref '(gnu packages compression) 'zlib)) ("zlib" (ref '(gnu packages compression) 'zlib))
("gzip" (ref '(gnu packages compression) 'gzip)) ("gzip" (ref '(gnu packages compression) 'gzip))
@ -92,6 +94,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json))
("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh))
("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git))
("guile2.0-gdbm-ffi" (ref '(gnu packages guile) 'guile2.0-gdbm-ffi))
;; XXX: No "guile2.0-sqlite3".
(_ #f)))) ;no such package (_ #f)))) ;no such package
@ -215,12 +219,23 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
"guile-git" "guile-git"
"guile2.0-git")) "guile2.0-git"))
(define guile-gdbm-ffi
(package-for-guile guile-version
"guile-gdbm-ffi"
"guile2.0-gdbm-ffi"))
(define guile-sqlite3
(package-for-guile guile-version
"guile-sqlite3"
"guile2.0-sqlite3"))
(define dependencies (define dependencies
(match (append-map (lambda (package) (match (append-map (lambda (package)
(cons (list "x" package) (cons (list "x" package)
(package-transitive-inputs package))) (package-transitive-propagated-inputs package)))
(list guile-git guile-json guile-ssh)) (list guile-git guile-json guile-ssh
guile-gdbm-ffi guile-sqlite3))
(((labels packages _ ...) ...) (((labels packages _ ...) ...)
packages))) packages)))
@ -573,7 +588,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
`(#:local-build? #f ;allow substitutes `(#:local-build? #f ;allow substitutes
;; Don't annoy people about _IONBF deprecation. ;; Don't annoy people about _IONBF deprecation.
#:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) ;; Initialize 'terminal-width' in (system repl debug)
;; to a large-enough value to make backtrace more
;; verbose.
#:env-vars (("GUILE_WARN_DEPRECATED" . "no")
("COLUMNS" . "200")))))
;;; ;;;

234
guix/store/database.scm Normal file
View File

@ -0,0 +1,234 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 store database)
#:use-module (sqlite3)
#:use-module (guix config)
#:use-module (guix serialization)
#:use-module (guix store deduplication)
#:use-module (guix base16)
#:use-module (guix build syscalls)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (ice-9 match)
#:export (sqlite-register
register-path
reset-timestamps))
;;; Code for working with the store database directly.
(define-syntax-rule (with-database file db exp ...)
"Open DB from FILE and close it when the dynamic extent of EXP... is left."
(let ((db (sqlite-open file)))
(dynamic-wind noop
(lambda ()
exp ...)
(lambda ()
(sqlite-close db)))))
(define (last-insert-row-id db)
;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
;; Work around that.
(let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();"
#:cache? #t))
(result (sqlite-fold cons '() stmt)))
(sqlite-finalize stmt)
(match result
((#(id)) id)
(_ #f))))
(define path-id-sql
"SELECT id FROM ValidPaths WHERE path = :path")
(define* (path-id db path)
"If PATH exists in the 'ValidPaths' table, return its numerical
identifier. Otherwise, return #f."
(let ((stmt (sqlite-prepare db path-id-sql #:cache? #t)))
(sqlite-bind-arguments stmt #:path path)
(let ((result (sqlite-fold cons '() stmt)))
(sqlite-finalize stmt)
(match result
((#(id) . _) id)
(_ #f)))))
(define update-sql
"UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
:deriver, narSize = :size WHERE id = :id")
(define insert-sql
"INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
VALUES (:path, :hash, :time, :deriver, :size)")
(define* (update-or-insert db #:key path deriver hash nar-size time)
"The classic update-if-exists and insert-if-doesn't feature that sqlite
doesn't exactly have... they've got something close, but it involves deleting
and re-inserting instead of updating, which causes problems with foreign keys,
of course. Returns the row id of the row that was modified or inserted."
(let ((id (path-id db path)))
(if id
(let ((stmt (sqlite-prepare db update-sql #:cache? #t)))
(sqlite-bind-arguments stmt #:id id
#:path path #:deriver deriver
#:hash hash #:size nar-size #:time time)
(sqlite-fold cons '() stmt)
(sqlite-finalize stmt)
(last-insert-row-id db))
(let ((stmt (sqlite-prepare db insert-sql #:cache? #t)))
(sqlite-bind-arguments stmt
#:path path #:deriver deriver
#:hash hash #:size nar-size #:time time)
(sqlite-fold cons '() stmt) ;execute it
(sqlite-finalize stmt)
(last-insert-row-id db)))))
(define add-reference-sql
"INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id
FROM ValidPaths WHERE path = :reference")
(define (add-references db referrer references)
"REFERRER is the id of the referring store item, REFERENCES is a list
containing store items being referred to. Note that all of the store items in
REFERENCES must already be registered."
(let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t)))
(for-each (lambda (reference)
(sqlite-reset stmt)
(sqlite-bind-arguments stmt #:referrer referrer
#:reference reference)
(sqlite-fold cons '() stmt) ;execute it
(sqlite-finalize stmt)
(last-insert-row-id db))
references)))
;; XXX figure out caching of statement and database objects... later
(define* (sqlite-register #:key db-file path (references '())
deriver hash nar-size)
"Registers this stuff in a database specified by DB-FILE. PATH is the string
path of some store item, REFERENCES is a list of string paths which the store
item PATH refers to (they need to be already registered!), DERIVER is a string
path of the derivation that created the store item PATH, HASH is the
base16-encoded sha256 hash of the store item denoted by PATH (prefixed with
\"sha256:\") after being converted to nar form, and nar-size is the size in
bytes of the store item denoted by PATH after being converted to nar form."
(with-database db-file db
(let ((id (update-or-insert db #:path path
#:deriver deriver
#:hash hash
#:nar-size nar-size
#:time (time-second (current-time time-utc)))))
(add-references db id references))))
;;;
;;; High-level interface.
;;;
;; TODO: Factorize with that in (gnu build install).
(define (reset-timestamps file)
"Reset the modification time on FILE and on all the files it contains, if
it's a directory."
(let loop ((file file)
(type (stat:type (lstat file))))
(case type
((directory)
(utime file 0 0 0 0)
(let ((parent file))
(for-each (match-lambda
(("." . _) #f)
((".." . _) #f)
((file . properties)
(let ((file (string-append parent "/" file)))
(loop file
(match (assoc-ref properties 'type)
((or 'unknown #f)
(stat:type (lstat file)))
(type type))))))
(scandir* parent))))
((symlink)
;; FIXME: Implement bindings for 'futime' to reset the timestamps on
;; symlinks.
#f)
(else
(utime file 0 0 0 0)))))
;; TODO: make this canonicalize store items that are registered. This involves
;; setting permissions and timestamps, I think. Also, run a "deduplication
;; pass", whatever that involves. Also, handle databases not existing yet
;; (what should the default behavior be? Figuring out how the C++ stuff
;; currently does it sounds like a lot of grepping for global
;; variables...). Also, return #t on success like the documentation says we
;; should.
(define* (register-path path
#:key (references '()) deriver prefix
state-directory (deduplicate? #t))
;; Priority for options: first what is given, then environment variables,
;; then defaults. %state-directory, %store-directory, and
;; %store-database-directory already handle the "environment variables /
;; defaults" question, so we only need to choose between what is given and
;; those.
"Register PATH as a valid store file, with REFERENCES as its list of
references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
given, it must be the name of the directory containing the new store to
initialize; if STATE-DIRECTORY is given, it must be a string containing the
absolute file name to the state directory of the store being initialized.
Return #t on success.
Use with care as it directly modifies the store! This is primarily meant to
be used internally by the daemon's build hook."
(let* ((db-dir (cond
(state-directory
(string-append state-directory "/db"))
(prefix
;; If prefix is specified, the value of NIX_STATE_DIR
;; (which affects %state-directory) isn't supposed to
;; affect db-dir, only the compile-time-customized
;; default should.
(string-append prefix %localstatedir "/guix/db"))
(else
%store-database-directory)))
(store-dir (if prefix
;; same situation as above
(string-append prefix %storedir)
%store-directory))
(to-register (if prefix
(string-append %storedir "/" (basename path))
;; note: we assume here that if path is, for
;; example, /foo/bar/gnu/store/thing.txt and prefix
;; isn't given, then an environment variable has
;; been used to change the store directory to
;; /foo/bar/gnu/store, since otherwise real-path
;; would end up being /gnu/store/thing.txt, which is
;; probably not the right file in this case.
path))
(real-path (string-append store-dir "/" (basename path))))
(let-values (((hash nar-size)
(nar-sha256 real-path)))
(reset-timestamps real-path)
(sqlite-register
#:db-file (string-append db-dir "/db.sqlite")
#:path to-register
#:references references
#:deriver deriver
#:hash (string-append "sha256:"
(bytevector->base16-string hash))
#:nar-size nar-size)
(when deduplicate?
(deduplicate real-path hash #:store store-dir)))))

148
guix/store/deduplication.scm Normal file
View File

@ -0,0 +1,148 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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/>.
;;; This houses stuff we do to files when they arrive at the store - resetting
;;; timestamps, deduplicating, etc.
(define-module (guix store deduplication)
#:use-module (guix hash)
#:use-module (guix build utils)
#:use-module (guix base16)
#:use-module (srfi srfi-11)
#:use-module (rnrs io ports)
#:use-module (ice-9 ftw)
#:use-module (guix serialization)
#:export (nar-sha256
deduplicate))
;; Would it be better to just make WRITE-FILE give size as well? I question
;; the general utility of this approach.
(define (counting-wrapper-port output-port)
"Some custom ports don't implement GET-POSITION at all. But if we want to
figure out how many bytes are being written, we will want to use that. So this
makes a wrapper around a port which implements GET-POSITION."
(let ((byte-count 0))
(make-custom-binary-output-port "counting-wrapper"
(lambda (bytes offset count)
(set! byte-count
(+ byte-count count))
(put-bytevector output-port bytes
offset count)
count)
(lambda ()
byte-count)
#f
(lambda ()
(close-port output-port)))))
(define (nar-sha256 file)
"Gives the sha256 hash of a file and the size of the file in nar form."
(let-values (((port get-hash) (open-sha256-port)))
(let ((wrapper (counting-wrapper-port port)))
(write-file file wrapper)
(force-output wrapper)
(force-output port)
(let ((hash (get-hash))
(size (port-position wrapper)))
(close-port wrapper)
(values hash size)))))
(define (tempname-in directory)
"Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
unused by the time you create anything with that name, but a good shot."
(let ((const-part (string-append directory "/.tmp-link-"
(number->string (getpid)))))
(let try ((guess-part
(number->string (random most-positive-fixnum) 16)))
(if (file-exists? (string-append const-part "-" guess-part))
(try (number->string (random most-positive-fixnum) 16))
(string-append const-part "-" guess-part)))))
(define* (get-temp-link target #:optional (link-prefix (dirname target)))
"Like mkstemp!, but instead of creating a new file and giving you the name,
it creates a new hardlink to TARGET and gives you the name. Since
cross-filesystem hardlinks don't work, the temp link must be created on the
same filesystem - where in that filesystem it is can be controlled by
LINK-PREFIX."
(let try ((tempname (tempname-in link-prefix)))
(catch 'system-error
(lambda ()
(link target tempname)
tempname)
(lambda (args)
(if (= (system-error-errno args) EEXIST)
(try (tempname-in link-prefix))
(throw 'system-error args))))))
;; There are 3 main kinds of errors we can get from hardlinking: "Too many
;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
;; "can't fit more stuff in this directory" (ENOSPC).
(define (replace-with-link target to-replace)
"Atomically replace the file TO-REPLACE with a link to TARGET. Note: TARGET
and TO-REPLACE must be on the same file system."
(let ((temp-link (get-temp-link target (dirname to-replace))))
(rename-file temp-link to-replace)))
(define-syntax-rule (false-if-system-error (errors ...) exp ...)
"Given ERRORS, a list of system error codes to ignore, evaluates EXP... and
return #f if any of the system error codes in the given list are thrown."
(catch 'system-error
(lambda ()
exp ...)
(lambda args
(if (member (system-error-errno args) (list errors ...))
#f
(apply throw args)))))
(define* (deduplicate path hash #:key (store %store-directory))
"Check if a store item with sha256 hash HASH already exists. If so,
replace PATH with a hardlink to the already-existing one. If not, register
PATH so that future duplicates can hardlink to it. PATH is assumed to be
under STORE."
(let* ((links-directory (string-append store "/.links"))
(link-file (string-append links-directory "/"
(bytevector->base16-string hash))))
(mkdir-p links-directory)
(if (file-is-directory? path)
;; Can't hardlink directories, so hardlink their atoms.
(for-each (lambda (file)
(unless (member file '("." ".."))
(deduplicate file (nar-sha256 file)
#:store store)))
(scandir path))
(if (file-exists? link-file)
(false-if-system-error (EMLINK)
(replace-with-link link-file path))
(catch 'system-error
(lambda ()
(link path link-file))
(lambda args
(let ((errno (system-error-errno args)))
(cond ((= errno EEXIST)
;; Someone else put an entry for PATH in
;; LINKS-DIRECTORY before we could. Let's use it.
(false-if-system-error (EMLINK)
(replace-with-link path link-file)))
((= errno ENOSPC)
;; There's not enough room in the directory index for
;; more entries in .links, but that's fine: we can
;; just stop.
#f)
(else (apply throw args))))))))))

18
m4/guix.m4
View File

@ -174,6 +174,24 @@ AC_DEFUN([GUIX_CHECK_GUILE_SSH], [
fi]) fi])
]) ])
dnl GUIX_CHECK_GUILE_SQLITE3
dnl
dnl Check whether a recent-enough Guile-Sqlite3 is available.
AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [
dnl Check whether 'sqlite-bind-arguments' is available. It was introduced
dnl in February 2018:
dnl <https://notabug.org/civodul/guile-sqlite3/commit/1cd1dec96a9999db48c0ff45bab907efc637247f>.
AC_CACHE_CHECK([whether Guile-Sqlite3 is available and recent enough],
[guix_cv_have_recent_guile_sqlite3],
[GUILE_CHECK([retval],
[(@ (sqlite3) sqlite-bind-arguments)])
if test "$retval" = 0; then
guix_cv_have_recent_guile_sqlite3="yes"
else
guix_cv_have_recent_guile_sqlite3="no"
fi])
])
dnl GUIX_TEST_ROOT_DIRECTORY dnl GUIX_TEST_ROOT_DIRECTORY
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
AC_CACHE_CHECK([for unit test root directory], AC_CACHE_CHECK([for unit test root directory],

86
tests/gexp.scm
View File

@ -23,6 +23,7 @@
#:use-module (guix grafts) #:use-module (guix grafts)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix build-system trivial)
#:use-module (guix tests) #:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix utils) #:select (call-with-temporary-directory))
@ -66,6 +67,27 @@
(run-with-store %store exp (run-with-store %store exp
#:guile-for-build (%guile-for-build)))) #:guile-for-build (%guile-for-build))))
(define %extension-package
;; Example of a package to use when testing 'with-extensions'.
(dummy-package "extension"
(build-system trivial-build-system)
(arguments
`(#:guile ,%bootstrap-guile
#:modules ((guix build utils))
#:builder
(begin
(use-modules (guix build utils))
(let* ((out (string-append (assoc-ref %outputs "out")
"/share/guile/site/"
(effective-version))))
(mkdir-p out)
(call-with-output-file (string-append out "/hg2g.scm")
(lambda (port)
(write '(define-module (hg2g)
#:export (the-answer))
port)
(write '(define the-answer 42) port)))))))))
(test-begin "gexp") (test-begin "gexp")
@ -739,6 +761,54 @@
(built-derivations (list drv)) (built-derivations (list drv))
(return (= 42 (call-with-input-file out read)))))) (return (= 42 (call-with-input-file out read))))))
(test-equal "gexp-extensions & ungexp"
(list sed grep)
((@@ (guix gexp) gexp-extensions)
#~(foo #$(with-extensions (list grep) #~+)
#+(with-extensions (list sed) #~-))))
(test-equal "gexp-extensions & ungexp-splicing"
(list grep sed)
((@@ (guix gexp) gexp-extensions)
#~(foo #$@(list (with-extensions (list grep) #~+)
(with-imported-modules '((foo))
(with-extensions (list sed) #~-))))))
(test-equal "gexp-extensions and literal Scheme object"
'()
((@@ (guix gexp) gexp-extensions) #t))
(test-assertm "gexp->derivation & with-extensions"
;; Create a fake Guile extension and make sure it is accessible both to the
;; imported modules and to the derivation build script.
(mlet* %store-monad
((extension -> %extension-package)
(module -> (scheme-file "x" #~( ;; splice!
(define-module (foo)
#:use-module (hg2g)
#:export (multiply))
(define (multiply x)
(* the-answer x)))
#:splice? #t))
(build -> (with-extensions (list extension)
(with-imported-modules `((guix build utils)
((foo) => ,module))
#~(begin
(use-modules (guix build utils)
(hg2g) (foo))
(call-with-output-file #$output
(lambda (port)
(write (list the-answer (multiply 2))
port)))))))
(drv (gexp->derivation "thingie" build
;; %BOOTSTRAP-GUILE is 2.0.
#:effective-version "2.0"))
(out -> (derivation->output-path drv)))
(mbegin %store-monad
(built-derivations (list drv))
(return (equal? '(42 84) (call-with-input-file out read))))))
(test-assertm "gexp->derivation #:references-graphs" (test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad (mlet* %store-monad
((one (text-file "one" (random-text))) ((one (text-file "one" (random-text)))
@ -948,6 +1018,22 @@
(return (and (zero? (close-pipe pipe)) (return (and (zero? (close-pipe pipe))
(string=? text str)))))))))) (string=? text str))))))))))
(test-assertm "program-file & with-extensions"
(let* ((exp (with-extensions (list %extension-package)
(gexp (begin
(use-modules (hg2g))
(display the-answer)))))
(file (program-file "program" exp
#:guile %bootstrap-guile)))
(mlet* %store-monad ((drv (lower-object file))
(out -> (derivation->output-path drv)))
(mbegin %store-monad
(built-derivations (list drv))
(let* ((pipe (open-input-pipe out))
(str (get-string-all pipe)))
(return (and (zero? (close-pipe pipe))
(= 42 (string->number str)))))))))
(test-assertm "scheme-file" (test-assertm "scheme-file"
(let* ((text (plain-file "foo" "Hello, world!")) (let* ((text (plain-file "foo" "Hello, world!"))
(scheme (scheme-file "bar" #~(list "foo" #$text)))) (scheme (scheme-file "bar" #~(list "foo" #$text))))

12
tests/pack.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -65,17 +65,17 @@
#:archiver %tar-bootstrap)) #:archiver %tar-bootstrap))
(check (gexp->derivation (check (gexp->derivation
"check-tarball" "check-tarball"
#~(let ((guile (string-append "." #$profile "/bin"))) #~(let ((bin (string-append "." #$profile "/bin")))
(setenv "PATH" (setenv "PATH"
(string-append #$%tar-bootstrap "/bin")) (string-append #$%tar-bootstrap "/bin"))
(system* "tar" "xvf" #$tarball) (system* "tar" "xvf" #$tarball)
(mkdir #$output) (mkdir #$output)
(exit (exit
(and (file-exists? (string-append guile "/guile")) (and (file-exists? (string-append bin "/guile"))
(string=? (string-append #$%bootstrap-guile "/bin") (string=? (string-append #$%bootstrap-guile "/bin")
(readlink guile)) (readlink bin))
(string=? (string-append (string-drop guile 1) (string=? (string-append ".." #$profile
"/guile") "/bin/guile")
(readlink "bin/Guile")))))))) (readlink "bin/Guile"))))))))
(built-derivations (list check)))) (built-derivations (list check))))

54
tests/store-database.scm Normal file
View File

@ -0,0 +1,54 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (test-store-database)
#:use-module (guix tests)
#:use-module ((guix store) #:hide (register-path))
#:use-module (guix store database)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64))
;; Test the (guix store database) module.
(define %store
(open-connection-for-tests))
(test-begin "store-database")
(test-assert "register-path"
(let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
"-fake")))
(when (valid-path? %store file)
(delete-paths %store (list file)))
(false-if-exception (delete-file file))
(let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
(drv (string-append file ".drv")))
(call-with-output-file file
(cut display "This is a fake store item.\n" <>))
(register-path file
#:references (list ref)
#:deriver drv)
(and (valid-path? %store file)
(equal? (references %store file) (list ref))
(null? (valid-derivers %store file))
(null? (referrers %store file))))))
(test-end "store-database")

64
tests/store-deduplication.scm Normal file
View File

@ -0,0 +1,64 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (test-store-deduplication)
#:use-module (guix tests)
#:use-module (guix store deduplication)
#:use-module (guix hash)
#:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module (guix build utils)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64))
(test-begin "store-deduplication")
(test-equal "deduplicate"
(cons* #t #f ;inode comparisons
2 (make-list 5 6)) ;'nlink' values
(call-with-temporary-directory
(lambda (store)
(let ((data (string->utf8 "Hello, world!"))
(identical (map (lambda (n)
(string-append store "/" (number->string n)))
(iota 5)))
(unique (string-append store "/unique")))
(for-each (lambda (file)
(call-with-output-file file
(lambda (port)
(put-bytevector port data))))
identical)
(call-with-output-file unique
(lambda (port)
(put-bytevector port (string->utf8 "This is unique."))))
(for-each (lambda (file)
(deduplicate file (sha256 data) #:store store))
identical)
(deduplicate unique (nar-sha256 unique) #:store store)
;; (system (string-append "ls -lRia " store))
(cons* (apply = (map (compose stat:ino stat) identical))
(= (stat:ino (stat unique))
(stat:ino (stat (car identical))))
(stat:nlink (stat unique))
(map (compose stat:nlink stat) identical))))))
(test-end "store-deduplication")