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 'wrap-program '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 'container-excursion 'scheme-indent-function 1))

19
Makefile.am
View File

@ -257,6 +257,17 @@ MODULES += \
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.
dist_noinst_DATA = guix/tests.scm guix/tests/http.scm
@ -379,6 +390,14 @@ SCM_TESTS += \
endif
if HAVE_GUILE_SQLITE3
SCM_TESTS += \
tests/store-database.scm \
tests/store-deduplication.scm
endif
SH_TESTS = \
tests/guix-build.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)])
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.
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{} 2018 Rutger Helling@*
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
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{})))
@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.
@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{}.
@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}
Return @code{#t} if @var{obj} is a G-expression.
@end deffn
@ -5160,6 +5190,7 @@ information about monads.)
[#:hash #f] [#:hash-algo #f] @
[#:recursive? #f] [#:env-vars '()] [#:modules '()] @
[#:module-path @var{%load-path}] @
[#:effective-version "2.2"] @
[#:references-graphs #f] [#:allowed-references #f] @
[#:disallowed-references #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
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
applicable.
@ -16159,6 +16193,64 @@ A simple setup for cat-avatar-generator can look like this:
%base-services))
@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
@subsubsection Certificate Services

19
gnu/bootloader/grub.scm
View File

@ -121,25 +121,14 @@ otherwise."
(define* (svg->png svg #:key width height)
"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.
;; TODO: Remove #:guile-for-build when 2.2 has become the default.
(mlet %store-monad ((guile (package->derivation guile-2.2 #:graft? #f)))
(gexp->derivation "grub-image.png"
(with-imported-modules '((gnu build svg))
(gexp->derivation "grub-image.png"
(with-imported-modules '((gnu build svg))
(with-extensions (list guile-rsvg guile-cairo)
#~(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))
(svg->png #+svg #$output
#:width #$width
#:height #$height)))
#:guile-for-build guile)))
#:height #$height))))))
(define* (grub-background-image config #:key (width 1024) (height 768))
"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
((? string?)
;; Nothing to do.
spec)
;; Nothing to do, but wait until SPEC shows up.
(resolve identity spec identity))
((? file-system-label?)
;; Resolve the label.
(resolve find-partition-by-label

27
gnu/build/marionette.scm
View File

@ -26,6 +26,7 @@
make-marionette
marionette-eval
wait-for-file
wait-for-tcp-port
marionette-control
marionette-screen-text
wait-for-screen-text
@ -187,6 +188,32 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
('failure
(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)
"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)

11
gnu/build/svg.scm
View File

@ -1,5 +1,5 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
@ -18,16 +18,11 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build svg)
#:use-module (rsvg)
#:use-module (cairo)
#:use-module (srfi srfi-11)
#: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
#:key
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-graph-diam-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/seq24-rename-mutex.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
"1m0w0wqnz983l7fpp5p9pdsqr7n3ybrzp8ywjcvn0rihsrzj65j6"))))
(build-system cmake-build-system)
(inputs
`(("python" ,python-wrapper)))
(home-page "https://github.com/rizsotto/Bear")
(synopsis "Tool for generating a compilation database")
(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 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Stefan Stefanović <stefanx2ovic@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -143,7 +144,8 @@ Qt-style API for Wayland clients.")
"sddm-" version ".tar.xz"))
(sha256
(base32
"0ch6rdppgy2vbzw0c2x9a4c6ry46vx7p6b76d8xbh2nvxh23xv0k"))))
"0ch6rdppgy2vbzw0c2x9a4c6ry46vx7p6b76d8xbh2nvxh23xv0k"))
(patches (search-patches "sddm-fix-build-with-qt-5.11-1024.patch"))))
(build-system cmake-build-system)
(native-inputs
`(("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
(package
(name "emacs-w3m")
(version "1.4.538+0.20141022")
(source (origin
(method url-fetch)
(uri (string-append "mirror://debian/pool/main/w/w3m-el/w3m-el_"
version ".orig.tar.gz"))
(sha256
(base32
"0zfxmq86pwk64yv0426gnjrvhjrgrjqn08sdcdhmmjmfpmqvm79y"))))
(build-system gnu-build-system)
(native-inputs `(("autoconf" ,autoconf)
("emacs" ,emacs-minimal)))
(inputs `(("w3m" ,w3m)
("imagemagick" ,imagemagick)))
(arguments
`(#:modules ((guix build gnu-build-system)
(guix build utils)
(guix build emacs-utils))
#:imported-modules (,@%gnu-build-system-modules
(guix build emacs-utils))
#:configure-flags
(let ((out (assoc-ref %outputs "out")))
(list (string-append "--with-lispdir="
out "/share/emacs/site-lisp")
(string-append "--with-icondir="
out "/share/images/emacs-w3m")
;; Leave .el files uncompressed, otherwise GC can't
;; identify run-time dependencies. See
;; <http://lists.gnu.org/archive/html/guix-devel/2015-12/msg00208.html>
"--without-compress-install"))
#:tests? #f ; no check target
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'autoconf
(lambda _
(zero? (system* "autoconf"))))
(add-before 'build 'patch-exec-paths
(lambda* (#:key inputs outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(w3m (assoc-ref inputs "w3m"))
(imagemagick (assoc-ref inputs "imagemagick"))
(coreutils (assoc-ref inputs "coreutils")))
(emacs-substitute-variables "w3m.el"
("w3m-command" (string-append w3m "/bin/w3m"))
("w3m-touch-command"
(string-append coreutils "/bin/touch"))
("w3m-image-viewer"
(string-append imagemagick "/bin/display"))
("w3m-icon-directory"
(string-append out "/share/images/emacs-w3m")))
(emacs-substitute-variables "w3m-image.el"
("w3m-imagick-convert-program"
(string-append imagemagick "/bin/convert"))
("w3m-imagick-identify-program"
(string-append imagemagick "/bin/identify")))
#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+)))
;; Emacs-w3m follows a "rolling release" model from its CVS repo. We could
;; use CVS, sure, but instead we choose to use this Git mirror described on
;; the home page as an "unofficial" mirror.
(let ((commit "0dd5691f46d314a84da63f3a7277d721815811a2"))
(package
(name "emacs-w3m")
(version (git-version "1.5" "0" commit))
(source (origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/ecbrown/emacs-w3m")
(commit commit)))
(sha256
(base32
"02xalyxbrkgl4n8nj7xxkmsbm6lshhwdc8bzs2l4wz3hkpgkj7x4"))))
(build-system gnu-build-system)
(native-inputs `(("autoconf" ,autoconf)
("texinfo" ,texinfo)
("emacs" ,emacs-minimal)))
(inputs `(("w3m" ,w3m)
("imagemagick" ,imagemagick)))
(arguments
`(#:modules ((guix build gnu-build-system)
(guix build utils)
(guix build emacs-utils))
#:imported-modules (,@%gnu-build-system-modules
(guix build emacs-utils))
#:configure-flags
(let ((out (assoc-ref %outputs "out")))
(list (string-append "--with-lispdir="
out "/share/emacs/site-lisp")
(string-append "--with-icondir="
out "/share/images/emacs-w3m")
;; Leave .el files uncompressed, otherwise GC can't
;; identify run-time dependencies. See
;; <http://lists.gnu.org/archive/html/guix-devel/2015-12/msg00208.html>
"--without-compress-install"))
#:tests? #f ; no check target
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'autoconf
(lambda _
(zero? (system* "autoconf"))))
(add-before 'configure 'support-emacs!
(lambda _
;; For some reason 'AC_PATH_EMACS' thinks that 'Emacs 26' is
;; unsupported.
(substitute* "configure"
(("EMACS_FLAVOR=unsupported")
"EMACS_FLAVOR=emacs"))
#t))
(add-before 'build 'patch-exec-paths
(lambda* (#:key inputs outputs #:allow-other-keys)
(let ((out (assoc-ref outputs "out"))
(w3m (assoc-ref inputs "w3m"))
(imagemagick (assoc-ref inputs "imagemagick"))
(coreutils (assoc-ref inputs "coreutils")))
(make-file-writable "w3m.el")
(emacs-substitute-variables "w3m.el"
("w3m-command" (string-append w3m "/bin/w3m"))
("w3m-touch-command"
(string-append coreutils "/bin/touch"))
("w3m-icon-directory"
(string-append out "/share/images/emacs-w3m")))
(make-file-writable "w3m-image.el")
(emacs-substitute-variables "w3m-image.el"
("w3m-imagick-convert-program"
(string-append imagemagick "/bin/convert"))
("w3m-imagick-identify-program"
(string-append imagemagick "/bin/identify")))
#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
(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
be changed by customizing the appropriate variables.")
(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-1459162.patch" "11d8a87fb6d6" "1rkmdk18llw0x1jakix75hlhy0hpsmlminnflagbzrzjli81gwm1")
(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)))
(snippet
'(begin

160
gnu/packages/haskell.scm
View File

@ -14,6 +14,7 @@
;;; Copyright © 2017 rsiddharth <s@ricketyspace.net>
;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2018 Tonton <tonton@riseup.net>
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;;
;;; 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.")
(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
(package
(name "ghc-text")
@ -2990,6 +3015,35 @@ online}.")
(description "This package provides a simple XML library for Haskell.")
(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
(package
(name "ghc-exceptions")
@ -3575,6 +3629,31 @@ vector types are supported. Specific instances are provided for unboxed,
boxed and storable vectors.")
(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
(package
(name "ghc-network")
@ -3760,6 +3839,27 @@ with various performance characteristics.")
manipulating monad transformer stacks.")
(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
(package
(name "ghc-monad-control")
@ -7738,6 +7838,44 @@ converting between Haskell values and JSON.
JSON (JavaScript Object Notation) is a lightweight data-interchange format.")
(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
(package
(name "shellcheck")
@ -7836,6 +7974,8 @@ bytestrings and their hexademical representation.")
(base32
"0n39s1i88j6s7vvsdhpbhcr3gpbwlzabwcc3nbd7nqb4kb4i0sls"))))
(build-system haskell-build-system)
(arguments
`(#:configure-flags (list "--allow-newer=QuickCheck")))
(inputs
`(("ghc-hashable" ,ghc-hashable)))
(native-inputs
@ -9518,4 +9658,24 @@ serialization code.")
(home-page "https://hackage.haskell.org/package/bytes")
(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

4
gnu/packages/messaging.scm
View File

@ -736,14 +736,14 @@ a graphical desktop environment like GNOME.")
(define-public prosody
(package
(name "prosody")
(version "0.10.1")
(version "0.10.2")
(source (origin
(method url-fetch)
(uri (string-append "https://prosody.im/downloads/source/"
"prosody-" version ".tar.gz"))
(sha256
(base32
"1kmmpkkgymg1r8r0k8j83pgmiskg1phl8hmpzjrnvlvsfnrnjplr"))))
"13knr7izscw0zx648b9582dx11aap4cq9bzfiqh5ykd7wwsz1dbm"))))
(build-system gnu-build-system)
(arguments
`(#: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
(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
(package
(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")
"-opensource"
"-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
;; into a separate output, but for the time being, we
;; prefer to save the space and build time.

62
gnu/packages/rust.scm
View File

@ -63,32 +63,34 @@
(package
(name "rust-bootstrap")
(version "1.22.1")
(source (origin
(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")
(_ ""))))))
(source #f)
(build-system gnu-build-system)
(native-inputs
`(("patchelf" ,patchelf)))
(inputs
`(("gcc" ,(canonical-package gcc))
("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"))
(arguments
`(#:tests? #f
@ -117,7 +119,7 @@
(invoke "bash" "install.sh"
(string-append "--prefix=" out)
(string-append "--components=rustc,"
"rust-std-" %host-type))
"rust-std-" ,(nix-system->gnu-triplet)))
;; Instal cargo
(invoke "bash" "install.sh"
(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:
;; https://github.com/rust-lang/rust/issues/45410
(("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)))
(add-after 'patch-source-shebangs 'patch-cargo-checksums
(lambda* _
@ -386,6 +394,10 @@ safety and thread safety guarantees.")
(substitute* "src/tools/cargo/tests/death.rs"
;; This is stuck when built in container.
(("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))
(add-after 'patch-cargo-tests 'fix-mtime-bug
(lambda* _
@ -433,7 +445,7 @@ rpath = true
# codegen/mainsubprogram.rs and codegen/mainsubprogramstart.rs
# This tests required patched LLVM
codegen-tests = false
[target." %host-type "]
[target." ,(nix-system->gnu-triplet) "]
llvm-config = \"" llvm "/bin/llvm-config" "\"
cc = \"" gcc "/bin/gcc" "\"
cxx = \"" gcc "/bin/g++" "\"
@ -456,8 +468,10 @@ jemalloc = \"" jemalloc "/lib/libjemalloc_pic.a" "\"
(invoke "./x.py" "build" "src/tools/cargo")))
(replace 'check
(lambda* _
(invoke "./x.py" "test")
(invoke "./x.py" "test" "src/tools/cargo")))
;; Disable parallel execution to prevent EAGAIN errors when
;; running tests.
(invoke "./x.py" "-j1" "test")
(invoke "./x.py" "-j1" "test" "src/tools/cargo")))
(replace 'install
(lambda* (#:key outputs #:allow-other-keys)
(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 © 2018 Sou Bunnbu <iyzsong@member.fsf.org>
;;; Copyright © 2018 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -84,6 +85,7 @@
#:use-module (gnu packages python)
#:use-module (gnu packages python-web)
#:use-module (gnu packages readline)
#:use-module (gnu packages rsync)
#:use-module (gnu packages databases)
#:use-module (gnu packages admin)
#: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
directory full of HOWTOs.")
(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 Rutger Helling <rhelling@mykolab.com>
;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@ -82,6 +83,7 @@
#:use-module (gnu packages gnuzilla)
#:use-module (gnu packages gperf)
#:use-module (gnu packages gtk)
#:use-module (gnu packages guile)
#:use-module (gnu packages java)
#:use-module (gnu packages javascript)
#:use-module (gnu packages jemalloc)
@ -96,6 +98,7 @@
#:use-module (gnu packages ncurses)
#:use-module (gnu packages openstack)
#:use-module (gnu packages base)
#:use-module (gnu packages package-management)
#:use-module (gnu packages perl)
#:use-module (gnu packages perl-check)
#:use-module (gnu packages python)
@ -6424,3 +6427,81 @@ compressed JSON header blocks.
@item @command{inflatehd} converts such compressed headers back to JSON pairs.
@end itemize\n")
(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 nee <nee-git@hidamari.blue>
;;; 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.
;;;
@ -25,11 +26,14 @@
(define-module (gnu services web)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu system pam)
#:use-module (gnu system shadow)
#:use-module (gnu packages admin)
#:use-module (gnu packages web)
#:use-module (gnu packages php)
#:use-module (gnu packages guile)
#:use-module (guix records)
#:use-module (guix modules)
#:use-module (guix gexp)
#:use-module ((guix utils) #:select (version-major))
#:use-module ((guix packages) #:select (package-version))
@ -155,7 +159,11 @@
php-fpm-service-type
nginx-php-location
cat-avatar-generator-service))
cat-avatar-generator-service
hpcguix-web-configuration
hpcguix-web-configuration?
hpcguix-web-service-type))
;;; Commentary:
;;;
@ -893,3 +901,65 @@ a webserver.")
(nginx-server-configuration-locations configuration)))
(root #~(string-append #$package
"/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
"/")))))
(x ;unsupported format
(warning (G_ "unrecognized boot parameters for '~a'~%")
system)
(warning (G_ "unrecognized boot parameters at '~a'~%")
(port-filename port))
#f)))
(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)
(define %libgcrypt
#+(file-append libgcrypt "/lib/libgcrypt"))))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz"))
(graph -> "system-graph"))
(define build
(with-imported-modules `(,@(source-module-closure '((guix docker)
(guix build utils)
(gnu build vm))
#:select? not-config?)
(guix build store-copy)
((guix config) => ,config))
#~(begin
;; Guile-JSON is required by (guix docker).
(add-to-load-path
(string-append #+guile-json "/share/guile/site/"
(effective-version)))
(use-modules (guix docker)
(guix build utils)
(gnu build vm)
(srfi srfi-19)
(guix build store-copy))
(with-extensions (list guile-json) ;for (guix docker)
(with-imported-modules `(,@(source-module-closure
'((guix docker)
(guix build utils)
(gnu build vm))
#:select? not-config?)
(guix build store-copy)
((guix config) => ,config))
#~(begin
(use-modules (guix docker)
(guix build utils)
(gnu build vm)
(srfi srfi-19)
(guix build store-copy))
(let* ((inputs '#$(append (list tar)
(if register-closures?
(list guix)
'())))
;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM.
(initialize (root-partition-initializer
#:closures '(#$graph)
#:register-closures? #$register-closures?
#:system-directory #$os-drv
;; De-duplication would fail due to
;; cross-device link errors, so don't do it.
#:deduplicate? #f))
;; Even as root in a VM, the initializer would fail due to
;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(mkdir root-directory)
(initialize root-directory)
(build-docker-image
(string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory
(call-with-input-file (string-append "/xchg/" #$graph)
read-reference-graph))
#$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> "")))))))
(let* ((inputs '#$(append (list tar)
(if register-closures?
(list guix)
'())))
;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM.
(initialize (root-partition-initializer
#:closures '(#$graph)
#:register-closures? #$register-closures?
#:system-directory #$os-drv
;; De-duplication would fail due to
;; cross-device link errors, so don't do it.
#:deduplicate? #f))
;; Even as root in a VM, the initializer would fail due to
;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
(mkdir root-directory)
(initialize root-directory)
(build-docker-image
(string-append "/xchg/" #$name) ;; The output file.
(cons* root-directory
(call-with-input-file (string-append "/xchg/" #$graph)
read-reference-graph))
#$os-drv
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> ""))))))))
(expression->derivation-in-linux-vm
name
;; 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
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -96,22 +96,7 @@
;; Wait until dicod is actually listening.
;; TODO: Use a PID file instead.
(test-assert "connect inside"
(marionette-eval
'(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))
(wait-for-tcp-port 2628 marionette))
(test-assert "connect"
(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
;;; 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 Marius Bakke <mbakke@fastmail.com>
;;;
@ -49,156 +49,150 @@ When SFTP? is true, run an SFTP server test."
(define test
(with-imported-modules '((gnu build marionette))
#~(begin
(eval-when (expand load eval)
;; Prepare to use Guile-SSH.
(set! %load-path
(cons (string-append #+guile-ssh "/share/guile/site/"
(effective-version))
%load-path)))
(with-extensions (list guile-ssh)
#~(begin
(use-modules (gnu build marionette)
(srfi srfi-26)
(srfi srfi-64)
(ice-9 match)
(ssh session)
(ssh auth)
(ssh channel)
(ssh sftp))
(use-modules (gnu build marionette)
(srfi srfi-26)
(srfi srfi-64)
(ice-9 match)
(ssh session)
(ssh auth)
(ssh channel)
(ssh sftp))
(define marionette
;; Enable TCP forwarding of the guest's port 22.
(make-marionette (list #$vm)))
(define marionette
;; Enable TCP forwarding of the guest's port 22.
(make-marionette (list #$vm)))
(define (make-session-for-test)
"Make a session with predefined parameters for a test."
(make-session #:user "root"
#:port 2222
#:host "localhost"
#:log-verbosity 'protocol))
(define (make-session-for-test)
"Make a session with predefined parameters for a test."
(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
(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
session is disconnected when the PROC is finished."
(let ((session (make-session-for-test)))
(dynamic-wind
(lambda ()
(let ((result (connect! session)))
(unless (equal? result 'ok)
(error "Could not connect to a server"
session result))))
(lambda () (proc session))
(lambda () (disconnect! session)))))
(let ((session (make-session-for-test)))
(dynamic-wind
(lambda ()
(let ((result (connect! session)))
(unless (equal? result 'ok)
(error "Could not connect to a server"
session result))))
(lambda () (proc session))
(lambda () (disconnect! session)))))
(define (call-with-connected-session/auth proc)
"Make an authenticated session. We should be able to connect as
(define (call-with-connected-session/auth proc)
"Make an authenticated session. We should be able to connect as
root with an empty password."
(call-with-connected-session
(lambda (session)
;; Try the simple authentication methods. Dropbear requires
;; 'none' when there are no passwords, whereas OpenSSH accepts
;; 'password' with an empty password.
(let loop ((methods (list (cut userauth-password! <> "")
(cut userauth-none! <>))))
(match methods
(()
(error "all the authentication methods failed"))
((auth rest ...)
(match (pk 'auth (auth session))
('success
(proc session))
('denied
(loop rest)))))))))
(call-with-connected-session
(lambda (session)
;; Try the simple authentication methods. Dropbear requires
;; 'none' when there are no passwords, whereas OpenSSH accepts
;; 'password' with an empty password.
(let loop ((methods (list (cut userauth-password! <> "")
(cut userauth-none! <>))))
(match methods
(()
(error "all the authentication methods failed"))
((auth rest ...)
(match (pk 'auth (auth session))
('success
(proc session))
('denied
(loop rest)))))))))
(mkdir #$output)
(chdir #$output)
(mkdir #$output)
(chdir #$output)
(test-begin "ssh-daemon")
(test-begin "ssh-daemon")
;; Wait for sshd to be up and running.
(test-eq "service running"
'running!
(marionette-eval
'(begin
(use-modules (gnu services herd))
(start-service 'ssh-daemon)
'running!)
marionette))
;; Wait for sshd to be up and running.
(test-eq "service running"
'running!
(marionette-eval
'(begin
(use-modules (gnu services herd))
(start-service 'ssh-daemon)
'running!)
marionette))
;; Check sshd's PID file.
(test-equal "sshd PID"
(wait-for-file #$pid-file marionette)
(marionette-eval
'(begin
(use-modules (gnu services herd)
(srfi srfi-1))
;; Check sshd's PID file.
(test-equal "sshd PID"
(wait-for-file #$pid-file marionette)
(marionette-eval
'(begin
(use-modules (gnu services herd)
(srfi srfi-1))
(live-service-running
(find (lambda (live)
(memq 'ssh-daemon
(live-service-provision live)))
(current-services))))
marionette))
(live-service-running
(find (lambda (live)
(memq 'ssh-daemon
(live-service-provision live)))
(current-services))))
marionette))
;; Connect to the guest over SSH. Make sure we can run a shell
;; command there.
(test-equal "shell command"
'hello
(call-with-connected-session/auth
(lambda (session)
;; FIXME: 'get-server-public-key' segfaults.
;; (get-server-public-key session)
(let ((channel (make-channel session)))
(channel-open-session channel)
(channel-request-exec channel "echo hello > /root/witness")
(and (zero? (channel-get-exit-status channel))
(wait-for-file "/root/witness" marionette))))))
;; Connect to the guest over SSH. Make sure we can run a shell
;; command there.
(test-equal "shell command"
'hello
(call-with-connected-session/auth
(lambda (session)
;; FIXME: 'get-server-public-key' segfaults.
;; (get-server-public-key session)
(let ((channel (make-channel session)))
(channel-open-session channel)
(channel-request-exec channel "echo hello > /root/witness")
(and (zero? (channel-get-exit-status channel))
(wait-for-file "/root/witness" marionette))))))
;; Connect to the guest over SFTP. Make sure we can write and
;; read a file there.
(unless #$sftp?
(test-skip 1))
(test-equal "SFTP file writing and reading"
'hello
(call-with-connected-session/auth
(lambda (session)
(let ((sftp-session (make-sftp-session session))
(witness "/root/sftp-witness"))
(call-with-remote-output-file sftp-session witness
(cut display "hello" <>))
(call-with-remote-input-file sftp-session witness
read)))))
;; Connect to the guest over SFTP. Make sure we can write and
;; read a file there.
(unless #$sftp?
(test-skip 1))
(test-equal "SFTP file writing and reading"
'hello
(call-with-connected-session/auth
(lambda (session)
(let ((sftp-session (make-sftp-session session))
(witness "/root/sftp-witness"))
(call-with-remote-output-file sftp-session witness
(cut display "hello" <>))
(call-with-remote-input-file sftp-session witness
read)))))
;; Connect to the guest over SSH. Make sure we can run commands
;; from the system profile.
(test-equal "run executables from system profile"
#t
(call-with-connected-session/auth
(lambda (session)
(let ((channel (make-channel session)))
(channel-open-session channel)
(channel-request-exec
channel
(string-append
"mkdir -p /root/.guix-profile/bin && "
"touch /root/.guix-profile/bin/path-witness && "
"chmod 755 /root/.guix-profile/bin/path-witness"))
(zero? (channel-get-exit-status channel))))))
;; Connect to the guest over SSH. Make sure we can run commands
;; from the system profile.
(test-equal "run executables from system profile"
#t
(call-with-connected-session/auth
(lambda (session)
(let ((channel (make-channel session)))
(channel-open-session channel)
(channel-request-exec
channel
(string-append
"mkdir -p /root/.guix-profile/bin && "
"touch /root/.guix-profile/bin/path-witness && "
"chmod 755 /root/.guix-profile/bin/path-witness"))
(zero? (channel-get-exit-status channel))))))
;; Connect to the guest over SSH. Make sure we can run commands
;; from the user profile.
(test-equal "run executable from user profile"
#t
(call-with-connected-session/auth
(lambda (session)
(let ((channel (make-channel session)))
(channel-open-session channel)
(channel-request-exec channel "path-witness")
(zero? (channel-get-exit-status channel))))))
;; Connect to the guest over SSH. Make sure we can run commands
;; from the user profile.
(test-equal "run executable from user profile"
#t
(call-with-connected-session/auth
(lambda (session)
(let ((channel (make-channel session)))
(channel-open-session channel)
(channel-request-exec channel "path-witness")
(zero? (channel-get-exit-status channel))))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))))))
(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 Christopher Baines <mail@cbaines.net>
;;; 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.
;;;
@ -31,7 +32,8 @@
#:use-module (guix store)
#:export (%test-httpd
%test-nginx
%test-php-fpm))
%test-php-fpm
%test-hpcguix-web))
(define %index.html-contents
;; Contents of the /index.html file.
@ -281,3 +283,81 @@ HTTP-PORT, along with php-fpm."
(name "php-fpm")
(description "Test PHP-FPM through nginx.")
(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
;;; 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.
;;;
@ -29,6 +30,7 @@
%store-directory
%state-directory
%store-database-directory
%config-directory
%guix-register-program
@ -80,6 +82,10 @@
(or (getenv "NIX_STATE_DIR")
(string-append %localstatedir "/guix")))
(define %store-database-directory
(or (and=> (getenv "NIX_DB_DIR") canonicalize-path)
(string-append %state-directory "/db")))
(define %config-directory
;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
(or (getenv "GUIX_CONFIGURATION_DIRECTORY")

6
guix/docker.scm
View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; 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>
;;;
;;; This file is part of GNU Guix.
@ -26,6 +26,7 @@
delete-file-recursively
with-directory-excursion
invoke))
#:use-module (json) ;guile-json
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module ((texinfo string-utils)
@ -34,9 +35,6 @@
#:use-module (ice-9 match)
#: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.
(define docker-id
(compose bytevector->base16-string sha256 string->utf8))

196
guix/gexp.scm
View File

@ -33,6 +33,7 @@
#:export (gexp
gexp?
with-imported-modules
with-extensions
gexp-input
gexp-input?
@ -118,10 +119,11 @@
;; "G expressions".
(define-record-type <gexp>
(make-gexp references modules proc)
(make-gexp references modules extensions proc)
gexp?
(references gexp-references) ;list of <gexp-input>
(modules gexp-self-modules) ;list of module names
(extensions gexp-self-extensions) ;list of lowerable things
(proc gexp-proc)) ;procedure
(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)
(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."
(define (gexp-attribute gexp self-attribute)
"Recurse on GEXP and the expressions it refers to, summing the items
returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
(if (gexp? gexp)
(delete-duplicates
(append (gexp-self-modules gexp)
(append (self-attribute gexp)
(append-map (match-lambda
(($ <gexp-input> (? gexp? exp))
(gexp-modules exp))
(gexp-attribute exp self-attribute))
(($ <gexp-input> (lst ...))
(append-map (lambda (item)
(if (gexp? item)
(gexp-modules item)
(gexp-attribute item
self-attribute)
'()))
lst))
(_
@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
(gexp-references gexp))))
'())) ;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
#:key system target)
"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 '())
(module-path %load-path)
(guile-for-build (%guile-for-build))
(effective-version "2.2")
(graft? (%graft?))
references-graphs
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
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
applicable.
@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
(map (match-lambda
;; TODO: Remove 'derivation?' special cases.
;; TODO: Remove 'derivation?' special cases.
((file-name (? derivation? drv))
(cons file-name (derivation->output-path drv)))
((file-name (? derivation? drv) sub-drv)
@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing)))
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 >>=
;; time.
(graft? (set-grafting graft?))
@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
#:target target))
(builder (text-file script-name
(object->string sexp)))
(extensions -> (gexp-extensions exp))
(exts (mapm %store-monad
(lambda (obj)
(lower-object obj system))
extensions))
(modules (if (pair? %modules)
(imported-modules %modules
#:system system
@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
(compiled-modules %modules
#:system system
#:module-path module-path
#:extensions extensions
#:guile guile-for-build
#:deprecation-warnings
deprecation-warnings)
@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
`("-L" ,(derivation->output-path modules)
"-C" ,(derivation->output-path compiled))
'())
,@(append-map extension-flags exts)
,builder)
#:outputs outputs
#:env-vars env-vars
@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
,@(if modules
`((,modules) (,compiled) ,@inputs)
inputs)
,@(map list exts)
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
@ -861,6 +893,17 @@ environment."
(identifier-syntax modules)))
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
(lambda (s)
(define (collect-escapes exp)
@ -957,6 +1000,7 @@ environment."
(refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs)
current-imported-modules
current-imported-extensions
(lambda #,formals
#,sexp)))))))
@ -1071,12 +1115,21 @@ last one is created from the given <scheme-file> object."
(system (%current-system))
(guile (%guile-for-build))
(module-path %load-path)
(extensions '())
(deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other."
(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
#:system system
#:guile guile
@ -1122,7 +1175,47 @@ they can refer to each other."
(setvbuf (current-output-port)
(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))
(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))
(chdir (ungexp modules))
(process-directory "." (ungexp output) 0))))
@ -1154,20 +1247,34 @@ they can refer to each other."
(module-ref (resolve-interface '(gnu packages guile))
'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
'%load-compiled-path' to point to MODULES, a list of module names. MODULES
are searched for in PATH."
(mlet %store-monad ((modules (imported-modules modules
#:module-path path))
(compiled (compiled-modules modules
#:extensions extensions
#:module-path path)))
(return (gexp (eval-when (expand load eval)
(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
(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
#: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."
(mlet %store-monad ((set-load-path
(load-path-expression (gexp-modules exp)
module-path)))
module-path
#:extensions
(gexp-extensions exp))))
(gexp->derivation name
(gexp
(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
'%load-path' and '%load-compiled-path' to honor EXP's imported modules.
Lookup EXP's modules in MODULE-PATH."
(match (if set-load-path? (gexp-modules exp) '())
(() ;zero modules
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(lambda (port)
(for-each (lambda (exp)
(write exp port))
'(ungexp (if splice?
exp
(gexp ((ungexp exp)))))))))
#:local-build? #t
#:substitutable? #f))
((modules ...)
(mlet %store-monad ((set-load-path (load-path-expression modules
module-path)))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(lambda (port)
(write '(ungexp set-load-path) port)
(for-each (lambda (exp)
(write exp port))
'(ungexp (if splice?
exp
(gexp ((ungexp exp)))))))))
#:module-path module-path
#:local-build? #t
#:substitutable? #f)))))
(define modules (gexp-modules exp))
(define extensions (gexp-extensions exp))
(if (or (not set-load-path?)
(and (null? modules) (null? extensions)))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(lambda (port)
(for-each (lambda (exp)
(write exp port))
'(ungexp (if splice?
exp
(gexp ((ungexp exp)))))))))
#:local-build? #t
#:substitutable? #f)
(mlet %store-monad ((set-load-path
(load-path-expression modules module-path
#:extensions extensions)))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
(lambda (port)
(write '(ungexp set-load-path) port)
(for-each (lambda (exp)
(write exp port))
'(ungexp (if splice?
exp
(gexp ((ungexp exp)))))))))
#:module-path module-path
#:local-build? #t
#:substitutable? #f))))
(define* (text-file* name #:rest text)
"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
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -19,6 +19,7 @@
(define-module (guix man-db)
#:use-module (guix zlib)
#:use-module ((guix build utils) #:select (find-files))
#:use-module (gdbm) ;gdbm-ffi
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
@ -44,9 +45,6 @@
;;;
;;; 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>
(mandb-entry file-name name section synopsis kind)
mandb-entry?

60
guix/profiles.scm
View File

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

31
guix/records.scm
View File

@ -63,22 +63,25 @@
(set-exception-printer! 'record-abi-mismatch-error
print-record-abi-mismatch-error)
(define (current-abi-identifier type)
"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")))))
(eval-when (expand load eval)
;; The procedures below are needed both at run time and at expansion time.
(define (abi-check type cookie)
"Return syntax that checks that the current \"application binary
(define (current-abi-identifier type)
"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."
(with-syntax ((current-abi (current-abi-identifier type)))
#`(unless (eq? current-abi #,cookie)
(throw 'record-abi-mismatch-error #,type))))
(with-syntax ((current-abi (current-abi-identifier type)))
#`(unless (eq? current-abi #,cookie)
(throw 'record-abi-mismatch-error #,type)))))
(define-syntax make-syntactic-constructor
(syntax-rules ()

37
guix/scripts/pack.scm
View File

@ -340,28 +340,25 @@ the image."
guile-json))
(define build
(with-imported-modules `(,@(source-module-closure '((guix docker))
#:select? not-config?)
(guix build store-copy)
((guix config) => ,config))
#~(begin
;; Guile-JSON is required by (guix docker).
(add-to-load-path
(string-append #+json "/share/guile/site/"
(effective-version)))
;; Guile-JSON is required by (guix docker).
(with-extensions (list json)
(with-imported-modules `(,@(source-module-closure '((guix docker))
#:select? not-config?)
(guix build store-copy)
((guix config) => ,config))
#~(begin
(use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
(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"
read-reference-graph)
#$profile
#:system (or #$target (utsname:machine (uname)))
#:symlinks '#$symlinks
#:compressor '#$(compressor-command compressor)
#:creation-time (make-time time-utc 0 1)))))
(build-docker-image #$output
(call-with-input-file "profile"
read-reference-graph)
#$profile
#:system (or #$target (utsname:machine (uname)))
#:symlinks '#$symlinks
#:compressor '#$(compressor-command compressor)
#:creation-time (make-time time-utc 0 1))))))
(gexp->derivation (string-append name ".tar"
(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")))
(define* (profile-boot-parameters #:optional (profile %system-profile)
(numbers (generation-numbers profile)))
"Return a list of 'boot-parameters' for the generations of PROFILE specified by
NUMBERS, which is a list of generation numbers."
(numbers
(reverse (generation-numbers profile))))
"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)
(unless-file-not-found
(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-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("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))
("zlib" (ref '(gnu packages compression) 'zlib))
("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-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh))
("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
@ -215,12 +219,23 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
"guile-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
(match (append-map (lambda (package)
(cons (list "x" package)
(package-transitive-inputs package)))
(list guile-git guile-json guile-ssh))
(package-transitive-propagated-inputs package)))
(list guile-git guile-json guile-ssh
guile-gdbm-ffi guile-sqlite3))
(((labels packages _ ...) ...)
packages)))
@ -573,7 +588,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
`(#:local-build? #f ;allow substitutes
;; 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])
])
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
AC_DEFUN([GUIX_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 derivations)
#:use-module (guix packages)
#:use-module (guix build-system trivial)
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix utils) #:select (call-with-temporary-directory))
@ -66,6 +67,27 @@
(run-with-store %store exp
#: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")
@ -739,6 +761,54 @@
(built-derivations (list drv))
(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"
(mlet* %store-monad
((one (text-file "one" (random-text)))
@ -948,6 +1018,22 @@
(return (and (zero? (close-pipe pipe))
(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"
(let* ((text (plain-file "foo" "Hello, world!"))
(scheme (scheme-file "bar" #~(list "foo" #$text))))

12
tests/pack.scm
View File

@ -1,5 +1,5 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
@ -65,17 +65,17 @@
#:archiver %tar-bootstrap))
(check (gexp->derivation
"check-tarball"
#~(let ((guile (string-append "." #$profile "/bin")))
#~(let ((bin (string-append "." #$profile "/bin")))
(setenv "PATH"
(string-append #$%tar-bootstrap "/bin"))
(system* "tar" "xvf" #$tarball)
(mkdir #$output)
(exit
(and (file-exists? (string-append guile "/guile"))
(and (file-exists? (string-append bin "/guile"))
(string=? (string-append #$%bootstrap-guile "/bin")
(readlink guile))
(string=? (string-append (string-drop guile 1)
"/guile")
(readlink bin))
(string=? (string-append ".." #$profile
"/bin/guile")
(readlink "bin/Guile"))))))))
(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")