From e13240f598d8e89eeb1fbf34fd94f49d6bf0b7a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2018 16:47:19 +0200 Subject: [PATCH 01/42] self: Reduce the set of dependencies. By mistake we were adding more dependencies than needed to the Scheme derivations. * guix/self.scm (compiled-guix)[dependencies]: Use 'package-transitive-propagated-inputs', not 'package-transitive-inputs'. --- guix/self.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/guix/self.scm b/guix/self.scm index 4378a3dee5..9620abf994 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -219,7 +219,7 @@ (define guile-git (define dependencies (match (append-map (lambda (package) (cons (list "x" package) - (package-transitive-inputs package))) + (package-transitive-propagated-inputs package))) (list guile-git guile-json guile-ssh)) (((labels packages _ ...) ...) packages))) From 69a05eab355f410e38ffd69007b9b8d740d92b59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2018 16:52:01 +0200 Subject: [PATCH 02/42] file-systems: Always wait for devices to show up. Previously, 'canonicalize-device-spec' would wait for devices when they were specified as a label or UUID, but would not wait when the user passed a "/dev" file name directly. This could cause problems when the /dev node takes a while to show up. * gnu/build/file-systems.scm (canonicalize-device-spec): Add 'resolve' call in the 'string?' case. --- gnu/build/file-systems.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 3dd7358fd3..3f97afeedd 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -499,8 +499,8 @@ (define (resolve find-partition spec fmt) (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 From b1059b38b280590881659ce2b82c22cdb29c5ba2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2018 17:31:19 +0200 Subject: [PATCH 03/42] system: 'read-boot-parameters' provides a more meaningful warning. 'system' here was bound to Guile's 'system' procedure. * gnu/system.scm (read-boot-parameters): Fix argument for fallback warning. --- gnu/system.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index 288c1e8801..dcef4ec09c 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -317,8 +317,8 @@ (define device-sexp->device (_ ;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) From 9768848af80764af6040e75867ae15a41228364b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2018 17:32:22 +0200 Subject: [PATCH 04/42] records: Make a couple of procedures available at expansion time. * guix/records.scm (current-abi-identifier, abi-check): Wrap in 'eval-when'. --- guix/records.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/guix/records.scm b/guix/records.scm index c71cfcfe32..da3ecdaaf8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -63,22 +63,25 @@ (define (print-record-abi-mismatch-error port key args (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 () From 73d854232fbdd38a59f1a514691f0411929b4adc Mon Sep 17 00:00:00 2001 From: Fis Trivial Date: Tue, 15 May 2018 12:10:11 +0000 Subject: [PATCH 05/42] gnu: bear: Fix python path. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/build-tools.scm (bear) [inputs]: Add python-wrapper. Signed-off-by: Ludovic Courtès --- gnu/packages/build-tools.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/gnu/packages/build-tools.scm b/gnu/packages/build-tools.scm index 4b078e78ed..a6d9fa8cfc 100644 --- a/gnu/packages/build-tools.scm +++ b/gnu/packages/build-tools.scm @@ -87,6 +87,8 @@ (define-public bear (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 From ec8a9892d12dcc016ec0e524cc475e74f0dbf280 Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Mon, 28 May 2018 10:30:38 +0200 Subject: [PATCH 06/42] gnu: Add python-bigfloat. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/python.scm (python-bigfloat, python2-bigfloat): New variables. Signed-off-by: Ludovic Courtès --- gnu/packages/python.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 39a367aec8..0cdf82594d 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -5155,6 +5155,29 @@ (define-public python-mpmath (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") From 45dca193a46b04f9ed06dd1b60de9ed7f40a482a Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Mon, 28 May 2018 10:42:37 +0200 Subject: [PATCH 07/42] gnu: Add emacs-org-caldav. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/emacs.scm (emacs-org-caldav): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/emacs.scm | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index 48c9a6de2a..d2fa5eb225 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -10551,3 +10551,27 @@ (define-public emacs-desktop-environment 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+))) From 555ab0853bdd5e226e60c3243f571ef9832c8ac9 Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Mon, 28 May 2018 13:07:02 +0200 Subject: [PATCH 08/42] gnu: Add emacs-zotxt. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/emacs.scm (emacs-zotxt): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/emacs.scm | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index d2fa5eb225..90b7fb2cae 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -10575,3 +10575,28 @@ (define-public emacs-org-caldav "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+))) From e90322d20189128cef27a6c4887e82e7ee4756c0 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Thu, 31 May 2018 17:56:38 -0400 Subject: [PATCH 09/42] gnu: prosody: Update to 0.10.2 [fixes CVE-2018-10847]. * gnu/packages/messaging.scm (prosody): Update to 0.10.2. --- gnu/packages/messaging.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm index 14783d802a..7a209f7799 100644 --- a/gnu/packages/messaging.scm +++ b/gnu/packages/messaging.scm @@ -736,14 +736,14 @@ (define-public dino (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 From 8fc3a971b0b0785895d1a23f7ad372026cb63550 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 17 Apr 2018 09:23:00 +0200 Subject: [PATCH 10/42] scripts: system: Sort profile generations in reverse order. * guix/scripts/system.scm (profile-boot-parameters): Reverse generation-numbers list. This allows old generations to be listed from most recent to oldest in bootloaders configuration files. --- guix/scripts/system.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 5d0df14924..766cab1aad 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -393,9 +393,11 @@ (define (seconds->string seconds) "~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)) From 8674abb1dda0278f81b5965985e6b78497aab386 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Stefan=20Stefanovi=C4=87?= Date: Fri, 1 Jun 2018 12:09:23 +0200 Subject: [PATCH 11/42] gnu: sddm: Fix CMake build. * gnu/packages/display-managers.scm (sddm): Fix CMake build. * gnu/local.mk (dist_patch_DATA): Register it. * gnu/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch: New file. Signed-off-by: Rutger Helling --- gnu/local.mk | 1 + gnu/packages/display-managers.scm | 4 ++- .../sddm-fix-build-with-qt-5.11-1024.patch | 28 +++++++++++++++++++ 3 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 gnu/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch diff --git a/gnu/local.mk b/gnu/local.mk index 7734586f0a..db04ee0cd8 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -1093,6 +1093,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 \ diff --git a/gnu/packages/display-managers.scm b/gnu/packages/display-managers.scm index 6e3d4912de..b0ad3df788 100644 --- a/gnu/packages/display-managers.scm +++ b/gnu/packages/display-managers.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2017 Sou Bunnbu ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2018 Stefan Stefanović ;;; ;;; This file is part of GNU Guix. ;;; @@ -143,7 +144,8 @@ (define-public sddm "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) diff --git a/gnu/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch b/gnu/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch new file mode 100644 index 0000000000..53c184230a --- /dev/null +++ b/gnu/packages/patches/sddm-fix-build-with-qt-5.11-1024.patch @@ -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) From 5ede50b850df9d0a7bd6f5e27def1d783c0f08a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2018 22:54:31 +0200 Subject: [PATCH 12/42] gnu: emacs-w3m: Update and allow builds with Emacs 26. * gnu/packages/emacs.scm (emacs-w3m)[source]: Grab the source from github.com. [native-inputs]: Add TEXINFO. [arguments]: Add 'support-emacs!' phase. In 'patch-exec-paths' phase, make w3m.el and w3m-image.el writable. Remove substitution for 'w3m-image-viewer', which no longer exists. --- gnu/packages/emacs.scm | 156 ++++++++++++++++++++++------------------- 1 file changed, 85 insertions(+), 71 deletions(-) diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index 90b7fb2cae..4aafb7355e 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -748,77 +748,91 @@ (define-public flycheck ;;; (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 - ;; - "--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 + ;; + "--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 From 7a4e2eaab34f7fad6951f312203ac0d9dfa3d44a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jun 2018 10:01:05 +0200 Subject: [PATCH 13/42] marionette: Add 'wait-for-tcp-port'. * gnu/build/marionette.scm (wait-for-tcp-port): New procedure. * gnu/tests/dict.scm (run-dicod-test)["connect inside"]: Use it instead of the inline loop. --- gnu/build/marionette.scm | 27 +++++++++++++++++++++++++++ gnu/tests/dict.scm | 19 ++----------------- 2 files changed, 29 insertions(+), 17 deletions(-) diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index 173a67cef9..bb018fc9c1 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -26,6 +26,7 @@ (define-module (gnu build marionette) make-marionette marionette-eval wait-for-file + wait-for-tcp-port marionette-control marionette-screen-text wait-for-screen-text @@ -187,6 +188,32 @@ (define* (wait-for-file file marionette ('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) diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm index b9c741e3e0..4431e37dc1 100644 --- a/gnu/tests/dict.scm +++ b/gnu/tests/dict.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,22 +96,7 @@ (define %dico-socket ;; 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))) From d6a4dfec90f6b9010165bce3884dcb5d76113355 Mon Sep 17 00:00:00 2001 From: Rouby Pierre-Antoine Date: Wed, 30 May 2018 11:41:46 +0200 Subject: [PATCH 14/42] gnu: Add hpcguix-web. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/package/web.scm (hpcguix-web): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/web.scm | 81 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm index e06247a7cc..fb967af9f9 100644 --- a/gnu/packages/web.scm +++ b/gnu/packages/web.scm @@ -25,6 +25,7 @@ ;;; Copyright © 2017 Pierre Langlois ;;; Copyright © 2017 Rutger Helling ;;; Copyright © 2018 Julien Lepiller +;;; Copyright © 2018 Pierre-Antoine Rouby ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,7 @@ (define-module (gnu packages web) #: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 @@ (define-module (gnu packages web) #: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) @@ -6427,3 +6430,81 @@ (define-public nghttp2 @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+)))) From 93b83eb31e35aedaafcc40cfbb9a8743e0f6352d Mon Sep 17 00:00:00 2001 From: Rouby Pierre-Antoine Date: Wed, 30 May 2018 11:47:04 +0200 Subject: [PATCH 15/42] services: Add hpcguix-web. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/service/web.scm (): New record-type. (%hpcguix-web-accounts): New variable. (%hpcguix-web-activation,hpcguix-web-shepherd-service, hpcguix-web-service-type): New procedures. * gnu/tests/web.scm (run-hpcguix-web-server-test): New procedure. (%hpcguix-web-specs, %hpcguix-web-os, %test-hpcguix-web): New variable. * doc/guix.texi (Web Services): Add 'hpcguix-web'. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 61 +++++++++++++++++++++++++++++++- gnu/services/web.scm | 72 +++++++++++++++++++++++++++++++++++++- gnu/tests/web.scm | 82 +++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 212 insertions(+), 3 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 09749b15e1..3b5078741d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 @@ -16159,6 +16160,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 diff --git a/gnu/services/web.scm b/gnu/services/web.scm index b336a8dd30..aae2f3db0d 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2017 Christopher Baines ;;; Copyright © 2017 nee ;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2018 Pierre-Antoine Rouby ;;; ;;; 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 @@ (define-module (gnu services web) 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 @@ (define* (cat-avatar-generator-service (nginx-server-configuration-locations configuration))) (root #~(string-append #$package "/share/web/cat-avatar-generator")))))) + + +(define-record-type* + hpcguix-web-configuration make-hpcguix-web-configuration + hpcguix-web-configuration? + + (package hpcguix-web-package (default hpcguix-web)) ; + + ;; 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)))))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 1912f8f79d..a6bf6efcfe 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ludovic Courtès ;;; Copyright © 2017 Christopher Baines ;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2018 Pierre-Antoine Rouby ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,8 @@ (define-module (gnu tests web) #: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 @@ (define %test-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)))) From 4c798726b45d892edc278f0b32462abed7742f8e Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Feb 2018 12:58:48 -0500 Subject: [PATCH 16/42] gnu: Add ghc-bloomfilter. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/package/haskell.scm (ghc-bloomfilter): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index c8fade065d..ece8797784 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -14,6 +14,7 @@ ;;; Copyright © 2017 rsiddharth ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice ;;; Copyright © 2018 Tonton +;;; Copyright © 2018 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -3573,6 +3574,31 @@ (define-public ghc-vector-binary-instances 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") From e3aae496f9965ba4dd6137bdefcbdfea42af7faa Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Feb 2018 19:07:44 -0500 Subject: [PATCH 17/42] gnu: Add ghc-feed. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/haskell.scm (ghc-feed): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index ece8797784..cb4ad7c0e8 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -2989,6 +2989,35 @@ (define-public ghc-xml (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") From a39e6faee9826ca473a0fdb8139a2fede25638d1 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Feb 2018 19:08:28 -0500 Subject: [PATCH 18/42] gnu: Add ghc-ifelse. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/haskell.scm (ghc-ifelse): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index cb4ad7c0e8..d82f88e3ba 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -3813,6 +3813,27 @@ (define-public ghc-mmorph 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") From 92c2097bc28a4f9d564805c18b102be9c745f10e Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 00:12:21 -0500 Subject: [PATCH 19/42] gnu: Add ghc-esqueleto. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/haskell.scm (ghc-esqueleto): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index d82f88e3ba..76daf5b54b 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -7812,6 +7812,44 @@ (define-public ghc-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") From 6950a4507392bec54ad84378dd0a2c2904238f65 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 00:25:04 -0500 Subject: [PATCH 20/42] gnu: Add ghc-safesemaphore. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/haskell.scm (ghc-safesemaphore): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index 76daf5b54b..8427ce99a8 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -1939,6 +1939,30 @@ (define-public ghc-parallel "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") From 1ea3971992068944977cb031cc6b21018bdd001e Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 02:56:58 -0500 Subject: [PATCH 21/42] gnu: ghc-psqueues: Allow building with newer versions of QuickCheck. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/haskell.scm (ghc-psqueues)[arguments]: Add configure flag to allow newer versions of QuickCheck. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index 8427ce99a8..073f5b739f 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -7972,6 +7972,8 @@ (define-public ghc-psqueues (base32 "0n39s1i88j6s7vvsdhpbhcr3gpbwlzabwcc3nbd7nqb4kb4i0sls")))) (build-system haskell-build-system) + (arguments + `(#:configure-flags (list "--allow-newer=QuickCheck"))) (inputs `(("ghc-hashable" ,ghc-hashable))) (native-inputs From 4e5d9bf20ecd8c888956c029fa5c47a74182b347 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 23:13:57 -0500 Subject: [PATCH 22/42] gnu: Add ghc-disk-free-space. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/haskell.scm (ghc-disk-free-space): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/haskell.scm | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index 073f5b739f..42670d6e41 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -9656,4 +9656,24 @@ (define-public ghc-bytes (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 From a078a6ec3bbc75d0765c63530e8d6b783d8b3949 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 29 May 2018 12:07:54 -0400 Subject: [PATCH 23/42] gnu: Add git-annex. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/version-control.scm (git-annex): New variable. Signed-off-by: Ludovic Courtès --- gnu/packages/version-control.scm | 129 +++++++++++++++++++++++++++++++ 1 file changed, 129 insertions(+) diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 7765936a3f..4597c374f8 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -20,6 +20,7 @@ ;;; Copyright © 2017 Oleg Pykhalov ;;; Copyright © 2018 Sou Bunnbu ;;; Copyright © 2018 Christopher Baines +;;; Copyright © 2018 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,6 +85,7 @@ (define-module (gnu packages version-control) #: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) @@ -1995,3 +1997,130 @@ (define-public src 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+)))) From 514026d7de36b299238aff9dfcc2f898fb04072a Mon Sep 17 00:00:00 2001 From: Robin Templeton Date: Tue, 29 May 2018 12:02:41 -0400 Subject: [PATCH 24/42] gnu: rust: Add support for building 32-bit packages on 64-bit hosts. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/rust.scm (rust-bootstrap, rust-1.23): Use nix-system->gnu-triplet to determine the system type. (rust-1.19): Use readelf instead of nm in the atomic-lock-free test. (rust-1.23): Disable the cargo_test_env test. Disable parallel execution of tests. Signed-off-by: Ludovic Courtès --- gnu/packages/rust.scm | 62 ++++++++++++++++++++++++++----------------- 1 file changed, 38 insertions(+), 24 deletions(-) diff --git a/gnu/packages/rust.scm b/gnu/packages/rust.scm index 51d4f6c040..62b5ee5ffa 100644 --- a/gnu/packages/rust.scm +++ b/gnu/packages/rust.scm @@ -63,32 +63,34 @@ (define rust-bootstrap (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 @@ (define rust-bootstrap (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 @@ (define-public rust-1.19 ;; 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 @@ (define-public rust-1.23 (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 @@ (define-public rust-1.23 # 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 @@ (define ref (stat "README.md")) (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") From 5d669883ecc104403c5d3ba7d172e9c02234577c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jun 2018 13:45:36 +0200 Subject: [PATCH 25/42] gexp: 'compiled-modules' no longer overrides (guix build utils). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Until now 'compiled-modules' would override (guix build utils) with its own. Thus, when asked to build a different (guix build utils), via #:module-path, it would fail badly because a (guix build utils) module was already loaded and possibly incompatible with the new one. This happened when running 'guix pull --branch=core-updates' from current master: in 'core-updates', (guix build utils) exports 'ignore-error?' but in 'master' it does not. Thus, 'guix pull' would fail with: no binding `invoke-error?' in module (guix build utils) builder for `/gnu/store/…-module-import-compiled.drv' failed with exit code 1 cannot build derivation `/gnu/store/…-compute-guix-derivation.drv': 1 dependencies couldn't be built This patch fixes it. * guix/gexp.scm (compiled-modules)[build-utils-hack?]: New variable. [build]: Load MODULES/build/utils.scm when it exists. --- guix/gexp.scm | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/guix/gexp.scm b/guix/gexp.scm index dd5eb81bd3..fdfd734245 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1075,6 +1075,14 @@ (define* (compiled-modules modules "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 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 @@ -1114,7 +1122,27 @@ (define (process-directory directory output) %auto-compilation-options)))) entries))) + (ungexp-splicing + (if build-utils-hack? + (gexp ((define mkdir-p + ;; Capture 'mkdir-p'. + (@ (guix build utils) mkdir-p)))) + '())) + (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))))) From 44057a461b1fa8102938c4e0f54d7cbc9dd09b03 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 30 May 2018 09:55:28 +0200 Subject: [PATCH 26/42] tests: Fix arguments in pack test. This is a follow-up to commit 5ffac538aa604b71814ac74579626f0d3110b96e. * tests/pack.scm (self-contained-tarball): Adjust arguments to "self-contained-tarball". --- tests/pack.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tests/pack.scm b/tests/pack.scm index 3bce715075..fcc53d12ef 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,7 +62,7 @@ (define %tar-bootstrap %bootstrap-coreutils&co) #:symlinks '(("/bin/Guile" -> "bin/guile")) #:compressor %gzip-compressor - #:tar %tar-bootstrap)) + #:archiver %tar-bootstrap)) (check (gexp->derivation "check-tarball" #~(let ((guile (string-append "." #$profile "/bin"))) From ccc951cab3172adfdaf6fd2dfa8f8cdb98358a69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jun 2018 15:17:41 +0200 Subject: [PATCH 27/42] pack: Adjust test to expect relative symlinks. Reported by Chris Marusich . Fixes . * tests/pack.scm ("self-contained-tarball"): Rename 'guile' to 'bin'. Expect 'bin/Guile' to be a relative symlink. --- tests/pack.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/pack.scm b/tests/pack.scm index fcc53d12ef..d4596f863a 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -65,17 +65,17 @@ (define %tar-bootstrap %bootstrap-coreutils&co) #: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)))) From 838e17d8050236a6d3ffde991fb0035412eb3046 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 18:14:37 +0200 Subject: [PATCH 28/42] gexp: Add 'with-extensions'. * guix/gexp.scm ()[extensions]: New field. (gexp-attribute): New procedure. (gexp-modules): Write in terms of 'gexp-attribute'. (gexp-extensions): New procedure. (gexp->derivation): Add #:effective-version. [extension-flags]: New procedure. Honor extensions of EXP. (current-imported-extensions): New syntax parameter. (with-extensions): New macro. (gexp): Honor CURRENT-IMPORTED-EXTENSIONS. (compiled-modules): Add #:extensions and honor it. (load-path-expression): Likewise. (gexp->script, gexp->file): Honor extensions. * tests/gexp.scm (%extension-package): New variable. ("gexp-extensions & ungexp") ("gexp-extensions & ungexp-splicing") ("gexp-extensions and literal Scheme object") ("gexp->derivation & with-extensions") ("program-file & with-extensions"): New tests. * doc/guix.texi (G-Expressions): Document 'with-extensions'. --- .dir-locals.el | 1 + doc/guix.texi | 33 ++++++++++ guix/gexp.scm | 168 ++++++++++++++++++++++++++++++++++++------------- tests/gexp.scm | 86 +++++++++++++++++++++++++ 4 files changed, 246 insertions(+), 42 deletions(-) diff --git a/.dir-locals.el b/.dir-locals.el index dac6cb1453..2db751ca22 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -73,6 +73,7 @@ (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 'call-with-container 'scheme-indent-function 1)) (eval . (put 'container-excursion 'scheme-indent-function 1)) diff --git a/doc/guix.texi b/doc/guix.texi index 3b5078741d..77bdaa50eb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5064,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} @@ -5147,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 @@ -5161,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] @ @@ -5181,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. diff --git a/guix/gexp.scm b/guix/gexp.scm index fdfd734245..338c339da9 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -33,6 +33,7 @@ (define-module (guix gexp) #:export (gexp gexp? with-imported-modules + with-extensions gexp-input gexp-input? @@ -118,10 +119,11 @@ (define-module (guix gexp) ;; "G expressions". (define-record-type - (make-gexp references modules proc) + (make-gexp references modules extensions proc) gexp? (references gexp-references) ;list of (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 @@ (define (write-gexp-output output port) (set-record-type-printer! 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? exp)) - (gexp-modules exp)) + (gexp-attribute exp self-attribute)) (($ (lst ...)) (append-map (lambda (item) (if (gexp? item) - (gexp-modules item) + (gexp-attribute item + self-attribute) '())) lst)) (_ @@ -512,6 +515,17 @@ (define (gexp-modules gexp) (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 @@ (define* (gexp->derivation name exp (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 @@ (define* (gexp->derivation name exp 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 @@ (define outputs (gexp-outputs exp)) (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 @@ (define (graphs-file-names graphs) (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 @@ (define (graphs-file-names graphs) #: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 @@ (define (graphs-file-names graphs) (compiled-modules %modules #:system system #:module-path module-path + #:extensions extensions #:guile guile-for-build #:deprecation-warnings deprecation-warnings) @@ -704,6 +734,7 @@ (define (graphs-file-names graphs) `("-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 @@ (define (graphs-file-names graphs) ,@(if modules `((,modules) (,compiled) ,@inputs) inputs) + ,@(map list exts) ,@(match graphs (((_ . inputs) ...) inputs) (_ '()))) @@ -861,6 +893,17 @@ (define-syntax-rule (with-imported-modules modules body ...) (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 @@ (define (substitute-references exp substs) (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) current-imported-modules + current-imported-extensions (lambda #,formals #,sexp))))))) @@ -1071,6 +1115,7 @@ (define* (compiled-modules modules (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 @@ -1129,6 +1174,26 @@ (define (process-directory directory output) (@ (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 @@ -1174,20 +1239,34 @@ (define (default-guile) (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)) @@ -1196,7 +1275,9 @@ (define* (gexp->script name exp 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) @@ -1225,35 +1306,38 @@ (define* (gexp->file name exp #:key 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 diff --git a/tests/gexp.scm b/tests/gexp.scm index 3c8b4624da..a560adfc5c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -23,6 +23,7 @@ (define-module (test-gexp) #: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 @@ (define-syntax-rule (test-assertm name exp) (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 @@ (define the-answer 42)) (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 @@ (define-public %stupid-thing ,text)) (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)))) From 13993c77fec7580f4f10ea07256db9e5f5a7949b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 18:22:24 +0200 Subject: [PATCH 29/42] pack: Use 'with-extensions' when referring to (guix docker). * guix/docker.scm: Use module (json) the normal way. * guix/scripts/pack.scm (docker-image)[build]: Wrap in 'with-extensions'. --- guix/docker.scm | 6 ++---- guix/scripts/pack.scm | 37 +++++++++++++++++-------------------- 2 files changed, 19 insertions(+), 24 deletions(-) diff --git a/guix/docker.scm b/guix/docker.scm index a75534c33b..b869901599 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -26,6 +26,7 @@ (define-module (guix docker) 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 @@ (define-module (guix docker) #: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)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 35b8a7e729..76729d8e10 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -340,28 +340,25 @@ (define json 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)) From ff913cf514b2a1d6d8400b24c675125387049b41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 18:23:24 +0200 Subject: [PATCH 30/42] tests: ssh: Use 'with-extensions'. * gnu/tests/ssh.scm (run-ssh-test)[test]: Wrap body in 'with-extensions'. Remove %load-path manipulation code. --- gnu/tests/ssh.scm | 262 ++++++++++++++++++++++------------------------ 1 file changed, 128 insertions(+), 134 deletions(-) diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm index 6abc6c2501..9247a43e6d 100644 --- a/gnu/tests/ssh.scm +++ b/gnu/tests/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2017 Clément Lassieur ;;; Copyright © 2017 Marius Bakke ;;; @@ -49,156 +49,150 @@ (define vm (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)) From 31a5d694a3b9200bfde253eafbaca118b773fb96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 18:27:07 +0200 Subject: [PATCH 31/42] bootloader: grub: Simplify 'svg->png'. * gnu/bootloader/grub.scm (svg->png): Remove now unneeded #:guile-for-build argument. --- gnu/bootloader/grub.scm | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index eca6d97b19..e90a6a11eb 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -121,25 +121,21 @@ (define (bootloader-theme config) (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)) - #~(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))) + (gexp->derivation "grub-image.png" + (with-imported-modules '((gnu build svg)) + #~(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))) + (use-modules (gnu build svg)) + (svg->png #+svg #$output + #:width #$width + #:height #$height))))) (define* (grub-background-image config #:key (width 1024) (height 768)) "Return the GRUB background image defined in CONFIG with a ratio of From 33d8a871042e73d6b236793d02e5a8287a47ebe4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 21:47:01 +0200 Subject: [PATCH 32/42] bootloader: grub: Use 'with-extensions'. * gnu/bootloader/grub.scm (svg->png): Use 'with-extensions'. Remove 'add-to-load-path' calls. * gnu/build/svg.scm: Use (rsvg) and (cairo) the normal way. Remove 'module-autoload!' calls. --- gnu/bootloader/grub.scm | 19 ++++++------------- gnu/build/svg.scm | 11 +++-------- 2 files changed, 9 insertions(+), 21 deletions(-) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index e90a6a11eb..a131f3b506 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -123,19 +123,12 @@ (define* (svg->png svg #:key width height) "Build a PNG of HEIGHT x WIDTH from SVG." (gexp->derivation "grub-image.png" (with-imported-modules '((gnu build svg)) - #~(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))))) + (with-extensions (list guile-rsvg guile-cairo) + #~(begin + (use-modules (gnu build svg)) + (svg->png #+svg #$output + #:width #$width + #:height #$height)))))) (define* (grub-background-image config #:key (width 1024) (height 768)) "Return the GRUB background image defined in CONFIG with a ratio of diff --git a/gnu/build/svg.scm b/gnu/build/svg.scm index b5474ec4a0..6f1f4b3684 100644 --- a/gnu/build/svg.scm +++ b/gnu/build/svg.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Andy Wingo ;;; ;;; This file is part of GNU Guix. @@ -18,16 +18,11 @@ ;;; along with GNU Guix. If not, see . (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 . -(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 From 331ac4cc239727992329207ba428b3f26cae91d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 22:00:11 +0200 Subject: [PATCH 33/42] profiles: Use 'with-extensions'. * guix/profiles.scm (manual-database)[build]: Use 'with-extensions'. Remove 'add-to-load-path' call. * guix/man-db.scm: Use (gdbm) the normal way; remove 'module-autoload!' call. --- guix/man-db.scm | 6 ++--- guix/profiles.scm | 60 +++++++++++++++++++++++------------------------ 2 files changed, 31 insertions(+), 35 deletions(-) diff --git a/guix/man-db.scm b/guix/man-db.scm index 732aef1083..4cef874f8b 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; 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 @@ (define-module (guix man-db) ;;; ;;; 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 file-name name section synopsis kind) mandb-entry? diff --git a/guix/profiles.scm b/guix/profiles.scm index fd7e5b922c..9bddf88162 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1196,41 +1196,39 @@ (define modules (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 From 9f160a0d3cc5f023dd65ba2bf47b4667196c7ca3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 28 May 2018 23:42:28 +0200 Subject: [PATCH 34/42] vm: Use 'with-extensions'. * gnu/system/vm.scm (system-docker-image)[build]: Use 'with-extensions'. Remove 'add-to-load-path' calls. --- gnu/system/vm.scm | 93 +++++++++++++++++++++++------------------------ 1 file changed, 46 insertions(+), 47 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index cf730d1f08..8cfbda2264 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -410,58 +410,57 @@ (define-module (guix config) (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 From d59e75f3b5b82692bd250a1a3a9965397bb588c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 27 May 2018 15:43:52 +0200 Subject: [PATCH 35/42] build: Check for Guile-SQLite3. * m4/guix.m4 (GUIX_CHECK_GUILE_SQLITE3): New macro. * configure.ac: Use it and define 'HAVE_GUILE_SQLITE3'. * guix/self.scm (specification->package): Add "guile-sqlite3". (compiled-guix)[guile-sqlite3]: New variable. [dependencies]: Add it. --- configure.ac | 5 +++++ guix/self.scm | 9 ++++++++- m4/guix.m4 | 18 ++++++++++++++++++ 3 files changed, 31 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 557da63189..d338bfda53 100644 --- a/configure.ac +++ b/configure.ac @@ -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]) diff --git a/guix/self.scm b/guix/self.scm index 9620abf994..64cf3033b7 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -82,6 +82,7 @@ (define specification->package ("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-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 +93,7 @@ (define specification->package ("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)) + ;; XXX: No "guile2.0-sqlite3". (_ #f)))) ;no such package @@ -216,11 +218,16 @@ (define guile-git "guile2.0-git")) + (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-propagated-inputs package))) - (list guile-git guile-json guile-ssh)) + (list guile-git guile-json guile-ssh guile-sqlite3)) (((labels packages _ ...) ...) packages))) diff --git a/m4/guix.m4 b/m4/guix.m4 index 8e174e92e5..a6897be961 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -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 . + 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], From 7f9d184d9b688d13ce76eefabaddcfa76bdde2b5 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 19:19:30 +0200 Subject: [PATCH 36/42] Add (gnu store database). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/config.scm.in (%store-database-directory): New variable. * guix/store/database.scm: New file. * tests/store-database.scm: New file. * Makefile.am (STORE_MODULES): New variable. (MODULES, MODULES_NOT_COMPILED): Adjust accordingly. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add tests/store-database.scm. Co-authored-by: Ludovic Courtès --- .dir-locals.el | 2 + Makefile.am | 17 +++ guix/config.scm.in | 6 + guix/store/database.scm | 234 +++++++++++++++++++++++++++++++++++++++ tests/store-database.scm | 54 +++++++++ 5 files changed, 313 insertions(+) create mode 100644 guix/store/database.scm create mode 100644 tests/store-database.scm diff --git a/.dir-locals.el b/.dir-locals.el index 2db751ca22..eb99a5bcc1 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -75,6 +75,8 @@ (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)) (eval . (put 'eventually 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 2a0a858429..d81fce5585 100644 --- a/Makefile.am +++ b/Makefile.am @@ -257,6 +257,16 @@ MODULES += \ endif BUILD_DAEMON_OFFLOAD +# Scheme implementation of the build daemon and related functionality. +STORE_MODULES = \ + guix/store/database.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 +389,13 @@ SCM_TESTS += \ endif +if HAVE_GUILE_SQLITE3 + +SCM_TESTS += \ + tests/store-database.scm + +endif + SH_TESTS = \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/guix/config.scm.in b/guix/config.scm.in index 8f2c4abd8e..dfe5fe0dbf 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2017 Caleb Ristvedt ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ (define-module (guix config) %store-directory %state-directory + %store-database-directory %config-directory %guix-register-program @@ -80,6 +82,10 @@ (define %state-directory (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") diff --git a/guix/store/database.scm b/guix/store/database.scm new file mode 100644 index 0000000000..4233219ba0 --- /dev/null +++ b/guix/store/database.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix store database) + #:use-module (sqlite3) + #:use-module (guix config) + #:use-module (guix serialization) + #:use-module (guix base16) + #:use-module (guix hash) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:export (sqlite-register + register-path)) + +;;; 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. +;;; + +;; XXX: 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))))) + +;; 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) + ;; 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))) + (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)))) diff --git a/tests/store-database.scm b/tests/store-database.scm new file mode 100644 index 0000000000..1348a75c26 --- /dev/null +++ b/tests/store-database.scm @@ -0,0 +1,54 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 2018 Ludovic Courtès +;;; +;;; 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 . + +(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") From 285cc75c3160421005ba0181490de4b290755b63 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 27 May 2018 21:32:17 +0200 Subject: [PATCH 37/42] database: 'register-path' resets timestamps. * guix/store/database.scm (reset-timestamps): New procedure. (register-path): Use it. --- guix/store/database.scm | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/guix/store/database.scm b/guix/store/database.scm index 4233219ba0..b9745dbe14 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -23,12 +23,14 @@ (define-module (guix store database) #:use-module (guix serialization) #:use-module (guix base16) #:use-module (guix hash) + #:use-module (guix build syscalls) #:use-module (rnrs io ports) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (ice-9 match) #:export (sqlite-register - register-path)) + register-path + reset-timestamps)) ;;; Code for working with the store database directly. @@ -171,6 +173,34 @@ (define (nar-sha256 file) (close-port wrapper) (values hash size))))) +;; 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 @@ -224,6 +254,7 @@ (define* (register-path 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 From bf5bf5778cb7c3a2475c6acd707abc925b1819aa Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 23:20:54 +0200 Subject: [PATCH 38/42] Add (guix store deduplication). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/store/database.scm (register-path): Add #:deduplicate? and call 'deduplicate' when it's true. (counting-wrapper-port, nar-sha256): Move to... * guix/store/deduplication.scm: ... here. New file. * tests/store-deduplication.scm: New file. * Makefile.am (STORE_MODULES): Add deduplication.scm. (SCM_TESTS) [HAVE_GUILE_SQLITE3]: Add store-deduplication.scm. Co-authored-by: Ludovic Courtès --- Makefile.am | 6 +- guix/store/database.scm | 43 ++-------- guix/store/deduplication.scm | 148 ++++++++++++++++++++++++++++++++++ tests/store-deduplication.scm | 64 +++++++++++++++ 4 files changed, 222 insertions(+), 39 deletions(-) create mode 100644 guix/store/deduplication.scm create mode 100644 tests/store-deduplication.scm diff --git a/Makefile.am b/Makefile.am index d81fce5585..474575c9f2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -259,7 +259,8 @@ endif BUILD_DAEMON_OFFLOAD # Scheme implementation of the build daemon and related functionality. STORE_MODULES = \ - guix/store/database.scm + guix/store/database.scm \ + guix/store/deduplication.scm if HAVE_GUILE_SQLITE3 MODULES += $(STORE_MODULES) @@ -392,7 +393,8 @@ endif if HAVE_GUILE_SQLITE3 SCM_TESTS += \ - tests/store-database.scm + tests/store-database.scm \ + tests/store-deduplication.scm endif diff --git a/guix/store/database.scm b/guix/store/database.scm index b9745dbe14..3623c0e7a0 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -21,10 +21,9 @@ (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 hash) #:use-module (guix build syscalls) - #:use-module (rnrs io ports) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (ice-9 match) @@ -140,39 +139,6 @@ (define* (sqlite-register #:key db-file path (references '()) ;;; High-level interface. ;;; -;; XXX: 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))))) - ;; 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 @@ -211,7 +177,7 @@ (define (reset-timestamps file) (define* (register-path path #:key (references '()) deriver prefix - state-directory) + 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 / @@ -262,4 +228,7 @@ (define* (register-path path #:deriver deriver #:hash (string-append "sha256:" (bytevector->base16-string hash)) - #:nar-size nar-size)))) + #:nar-size nar-size) + + (when deduplicate? + (deduplicate real-path hash #:store store-dir))))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm new file mode 100644 index 0000000000..4b4ac01f64 --- /dev/null +++ b/guix/store/deduplication.scm @@ -0,0 +1,148 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +;;; 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)))))))))) diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm new file mode 100644 index 0000000000..04817a193a --- /dev/null +++ b/tests/store-deduplication.scm @@ -0,0 +1,64 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(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") From 65a9f6b6cf3e41a4bbb144d03c5c440dd01d25dc Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 1 Jun 2018 13:19:25 +0200 Subject: [PATCH 39/42] gnu: qtbase: Fix build on older kernels. * gnu/packages/qt.scm (qtbase)[arguments]: Add configure flags "-no-feature-getentropy" and "-no-feature-renameat2". --- gnu/packages/qt.scm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm index c3d0bff2f1..a48a04fe48 100644 --- a/gnu/packages/qt.scm +++ b/gnu/packages/qt.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2015, 2016, 2017, 2018 Efraim Flashner ;;; Copyright © 2016, 2017 Nils Gillmann ;;; Copyright © 2016 Thomas Danckaert -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2017 Quiliro ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice ;;; Copyright © 2018 Nicolas Goaziou @@ -487,6 +487,16 @@ (define-public qtbase 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. From 6d52844cd4c376b7b344b448de8a2c7a3d252afb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jun 2018 17:31:44 +0200 Subject: [PATCH 40/42] self: Add dependency on guile-gdbm-ffi. Fixes a regression introduced in 331ac4cc239727992329207ba428b3f26cae91d9 whereby "guile-gdbm-ffi" would now be mandatory. * guix/self.scm (specification->package): Add "guile-gdbm-ffi" and "guile2.0-gdbm-ffi". (compiled-guix)[guile-gdbm-ffi]: New variables. [dependencies]: Add it. --- guix/self.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/guix/self.scm b/guix/self.scm index 64cf3033b7..9ff949075d 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -82,6 +82,7 @@ (define specification->package ("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)) @@ -93,6 +94,7 @@ (define specification->package ("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 @@ -217,6 +219,11 @@ (define guile-git "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 @@ -227,7 +234,8 @@ (define dependencies (match (append-map (lambda (package) (cons (list "x" package) (package-transitive-propagated-inputs package))) - (list guile-git guile-json guile-ssh guile-sqlite3)) + (list guile-git guile-json guile-ssh + guile-gdbm-ffi guile-sqlite3)) (((labels packages _ ...) ...) packages))) From 54be2b4d759c9e40c5b564726f882470bbac4387 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jun 2018 18:36:28 +0200 Subject: [PATCH 41/42] self: Show backtraces on more columns. * guix/self.scm (compiled-modules): Add "COLUMNS" to #:env-vars. --- guix/self.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/guix/self.scm b/guix/self.scm index 9ff949075d..3503fbda43 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -588,7 +588,11 @@ (define (process-directory directory output) `(#: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"))))) ;;; From 1a3e3162acafd32ff2fb675f2f780d986692c52d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 1 Jun 2018 02:20:03 -0400 Subject: [PATCH 42/42] gnu: icecat: Add more fixes from upstream esr52. * gnu/packages/gnuzilla.scm (icecat)[source]: Add selected fixes from the upstream mozilla-esr52 repository. --- gnu/packages/gnuzilla.scm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/gnu/packages/gnuzilla.scm b/gnu/packages/gnuzilla.scm index 84b535d19d..bbe1c77b99 100644 --- a/gnu/packages/gnuzilla.scm +++ b/gnu/packages/gnuzilla.scm @@ -484,7 +484,17 @@ (define-public icecat (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