From e13240f598d8e89eeb1fbf34fd94f49d6bf0b7a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 16:47:19 +0200 Subject: 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 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (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))) -- cgit v1.2.3 From 69a05eab355f410e38ffd69007b9b8d740d92b59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 16:52:01 +0200 Subject: 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 @@ were found." (match spec ((? string?) - ;; Nothing to do. - spec) + ;; Nothing to do, but wait until SPEC shows up. + (resolve identity spec identity)) ((? file-system-label?) ;; Resolve the label. (resolve find-partition-by-label -- cgit v1.2.3 From b1059b38b280590881659ce2b82c22cdb29c5ba2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 17:31:19 +0200 Subject: 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 @@ file system labels." (_ ;the old format "/"))))) (x ;unsupported format - (warning (G_ "unrecognized boot parameters for '~a'~%") - system) + (warning (G_ "unrecognized boot parameters at '~a'~%") + (port-filename port)) #f))) (define (read-boot-parameters-file system) -- cgit v1.2.3 From 9768848af80764af6040e75867ae15a41228364b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 17:32:22 +0200 Subject: 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 @@ (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 +(eval-when (expand load eval) + ;; The procedures below are needed both at run time and at expansion time. + + (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 + (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 () -- cgit v1.2.3 From 73d854232fbdd38a59f1a514691f0411929b4adc Mon Sep 17 00:00:00 2001 From: Fis Trivial Date: Tue, 15 May 2018 12:10:11 +0000 Subject: 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 @@ makes a few sacrifices to acquire fast full and incremental build times.") (base32 "1m0w0wqnz983l7fpp5p9pdsqr7n3ybrzp8ywjcvn0rihsrzj65j6")))) (build-system cmake-build-system) + (inputs + `(("python" ,python-wrapper))) (home-page "https://github.com/rizsotto/Bear") (synopsis "Tool for generating a compilation database") (description "A JSON compilation database is used in the Clang project to -- cgit v1.2.3 From ec8a9892d12dcc016ec0e524cc475e74f0dbf280 Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Mon, 28 May 2018 10:30:38 +0200 Subject: 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 @@ more advanced mathematics.") (define-public python2-mpmath (package-with-python2 python-mpmath)) +(define-public python-bigfloat + (package + (name "python-bigfloat") + (version "0.3.0") + (source + (origin + (method url-fetch) + (uri (pypi-uri "bigfloat" version)) + (sha256 + (base32 "0xd7q4l7v0f463diznjv4k9wlaks80pn9drdqmfifi7zx8qvybi6")))) + (build-system python-build-system) + (inputs + `(("mpfr" ,mpfr))) + (home-page "https://github.com/mdickinson/bigfloat") + (synopsis "Arbitrary precision floating-point arithmetic for Python") + (description + "This packages provides a Python interface to the MPFR library for +multiprecision arithmetic.") + (license license:lgpl3+))) + +(define-public python2-bigfloat + (package-with-python2 python-bigfloat)) + (define-public python-sympy (package (name "python-sympy") -- cgit v1.2.3 From 45dca193a46b04f9ed06dd1b60de9ed7f40a482a Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Mon, 28 May 2018 10:42:37 +0200 Subject: 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 @@ well as take screenshots and lock your screen. The package depends on the availability of shell commands to do the hard work for us. These commands can be changed by customizing the appropriate variables.") (license license:gpl3+))) + +(define-public emacs-org-caldav + (package + (name "emacs-org-caldav") + (version "20180403") + (source + (origin + (method url-fetch) + (uri (string-append + "https://github.com/dengste/org-caldav/raw/" + "8d3492c27a09f437d2d94f2736c56d7652e87aa0" + "/org-caldav.el")) + (sha256 + (base32 + "1fh4gh68ddj0is99z2ccyh97v6psnyda61n2dsadzqhcxn51amlc")))) + (build-system emacs-build-system) + (propagated-inputs `(("emacs-org" ,emacs-org))) + (home-page "https://github.com/dengste/org-caldav") + (synopsis + "Sync Org files with external calendars via the CalDAV protocol") + (description + "Synchronize between events in Org-mode files and a CalDAV calendar. +This code is still alpha.") + (license license:gpl3+))) -- cgit v1.2.3 From 555ab0853bdd5e226e60c3243f571ef9832c8ac9 Mon Sep 17 00:00:00 2001 From: Konrad Hinsen Date: Mon, 28 May 2018 13:07:02 +0200 Subject: 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 @@ be changed by customizing the appropriate variables.") "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+))) -- cgit v1.2.3 From e90322d20189128cef27a6c4887e82e7ee4756c0 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Thu, 31 May 2018 17:56:38 -0400 Subject: 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 @@ a graphical desktop environment like GNOME.") (define-public prosody (package (name "prosody") - (version "0.10.1") + (version "0.10.2") (source (origin (method url-fetch) (uri (string-append "https://prosody.im/downloads/source/" "prosody-" version ".tar.gz")) (sha256 (base32 - "1kmmpkkgymg1r8r0k8j83pgmiskg1phl8hmpzjrnvlvsfnrnjplr")))) + "13knr7izscw0zx648b9582dx11aap4cq9bzfiqh5ykd7wwsz1dbm")))) (build-system gnu-build-system) (arguments `(#:tests? #f ; no "check" target -- cgit v1.2.3 From 8fc3a971b0b0785895d1a23f7ad372026cb63550 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 17 Apr 2018 09:23:00 +0200 Subject: 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 @@ it atomically, and then run OS's activation script." "~Y-~m-~d ~H:~M"))) (define* (profile-boot-parameters #:optional (profile %system-profile) - (numbers (generation-numbers profile))) - "Return a list of 'boot-parameters' for the generations of PROFILE specified by -NUMBERS, which is a list of generation numbers." + (numbers + (reverse (generation-numbers profile)))) + "Return a list of 'boot-parameters' for the generations of PROFILE specified +by NUMBERS, which is a list of generation numbers. The list is ordered from +the most recent to the oldest profiles." (define (system->boot-parameters system number time) (unless-file-not-found (let* ((params (read-boot-parameters-file system)) -- cgit v1.2.3 From 8674abb1dda0278f81b5965985e6b78497aab386 Mon Sep 17 00:00:00 2001 From: Stefan Stefanović Date: Fri, 1 Jun 2018 12:09:23 +0200 Subject: 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 +++- .../patches/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 @@ Qt-style API for Wayland clients.") "sddm-" version ".tar.xz")) (sha256 (base32 - "0ch6rdppgy2vbzw0c2x9a4c6ry46vx7p6b76d8xbh2nvxh23xv0k")))) + "0ch6rdppgy2vbzw0c2x9a4c6ry46vx7p6b76d8xbh2nvxh23xv0k")) + (patches (search-patches "sddm-fix-build-with-qt-5.11-1024.patch")))) (build-system cmake-build-system) (native-inputs `(("extra-cmake-modules" ,extra-cmake-modules) 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) -- cgit v1.2.3 From 5ede50b850df9d0a7bd6f5e27def1d783c0f08a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 31 May 2018 22:54:31 +0200 Subject: 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 @@ provides an optional IDE-like error list.") ;;; (define-public emacs-w3m - (package - (name "emacs-w3m") - (version "1.4.538+0.20141022") - (source (origin - (method url-fetch) - (uri (string-append "mirror://debian/pool/main/w/w3m-el/w3m-el_" - version ".orig.tar.gz")) - (sha256 - (base32 - "0zfxmq86pwk64yv0426gnjrvhjrgrjqn08sdcdhmmjmfpmqvm79y")))) - (build-system gnu-build-system) - (native-inputs `(("autoconf" ,autoconf) - ("emacs" ,emacs-minimal))) - (inputs `(("w3m" ,w3m) - ("imagemagick" ,imagemagick))) - (arguments - `(#:modules ((guix build gnu-build-system) - (guix build utils) - (guix build emacs-utils)) - #:imported-modules (,@%gnu-build-system-modules - (guix build emacs-utils)) - #:configure-flags - (let ((out (assoc-ref %outputs "out"))) - (list (string-append "--with-lispdir=" - out "/share/emacs/site-lisp") - (string-append "--with-icondir=" - out "/share/images/emacs-w3m") - ;; Leave .el files uncompressed, otherwise GC can't - ;; identify run-time dependencies. See - ;; - "--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 -- cgit v1.2.3 From 7a4e2eaab34f7fad6951f312203ac0d9dfa3d44a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 10:01:05 +0200 Subject: 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 @@ make-marionette marionette-eval wait-for-file + wait-for-tcp-port marionette-control marionette-screen-text wait-for-screen-text @@ -187,6 +188,32 @@ FILE has not shown up after TIMEOUT seconds, raise an error." ('failure (error "file didn't show up" file)))) +(define* (wait-for-tcp-port port marionette + #:key (timeout 20)) + "Wait for up to TIMEOUT seconds for PORT to accept connections in +MARIONETTE. Raise an error on failure." + ;; Note: The 'connect' loop has to run within the guest because, when we + ;; forward ports to the host, connecting to the host never raises + ;; ECONNREFUSED. + (match (marionette-eval + `(begin + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (let loop ((i 0)) + (catch 'system-error + (lambda () + (connect sock AF_INET INADDR_LOOPBACK ,port) + 'success) + (lambda args + (if (< i ,timeout) + (begin + (sleep 1) + (loop (+ 1 i))) + 'failure)))))) + marionette) + ('success #t) + ('failure + (error "nobody's listening on port" port)))) + (define (marionette-control command marionette) "Run COMMAND in the QEMU monitor of MARIONETTE. COMMAND is a string such as \"sendkey ctrl-alt-f1\" or \"screendump foo.ppm\" (info \"(qemu-doc) 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 @@ ;; 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))) -- cgit v1.2.3 From d6a4dfec90f6b9010165bce3884dcb5d76113355 Mon Sep 17 00:00:00 2001 From: Rouby Pierre-Antoine Date: Wed, 30 May 2018 11:41:46 +0200 Subject: 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 @@ #:use-module (gnu packages gnuzilla) #:use-module (gnu packages gperf) #:use-module (gnu packages gtk) + #:use-module (gnu packages guile) #:use-module (gnu packages java) #:use-module (gnu packages javascript) #:use-module (gnu packages jemalloc) @@ -96,6 +98,7 @@ #:use-module (gnu packages ncurses) #:use-module (gnu packages openstack) #:use-module (gnu packages base) + #:use-module (gnu packages package-management) #:use-module (gnu packages perl) #:use-module (gnu packages perl-check) #:use-module (gnu packages python) @@ -6427,3 +6430,81 @@ compressed JSON header blocks. @item @command{inflatehd} converts such compressed headers back to JSON pairs. @end itemize\n") (license l:expat))) + +(define-public hpcguix-web + (let ((commit "3e3b9a3a406ee2dcd10c96cbedcc16ea378e8e8f")) + (package + (name "hpcguix-web") + (version (git-version "0.0.1" "0" commit)) + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/UMCUGenetics/hpcguix-web.git") + (commit commit))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "01888byi9mh7d3adcmwhmg44kg98g92r44ilc4wd7an66mjnxpry")))) + (build-system gnu-build-system) + (arguments + `(#:modules ((guix build gnu-build-system) + (guix build utils) + (srfi srfi-26) + (ice-9 popen) + (ice-9 rdelim)) + + #:phases + (modify-phases %standard-phases + (add-before 'configure 'autoconf + (lambda _ + (setenv "GUILE_AUTO_COMPILE" "0") + (setenv "XDG_CACHE_HOME" (getcwd)) + (invoke "autoreconf" "-vif"))) + (add-after 'install 'wrap-program + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (guix (assoc-ref inputs "guix")) + (guile (assoc-ref inputs "guile")) + (json (assoc-ref inputs "guile-json")) + (guile-cm (assoc-ref inputs + "guile-commonmark")) + (deps (list guile guile-cm guix json)) + (effective + (read-line + (open-pipe* OPEN_READ + (string-append guile "/bin/guile") + "-c" "(display (effective-version))"))) + (path (string-join + (map (cut string-append <> + "/share/guile/site/" + effective) + deps) + ":")) + (gopath (string-join + (map (cut string-append <> + "/lib/guile/" effective + "/site-ccache") + deps) + ":"))) + (wrap-program (string-append out "/bin/run") + `("GUILE_LOAD_PATH" ":" prefix (,path)) + `("GUILE_LOAD_COMPILED_PATH" ":" prefix (,gopath))) + + #t)))))) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("uglify-js" ,uglify-js) + ("pkg-config" ,pkg-config))) + (inputs + `(("guix" ,guix))) + (propagated-inputs + `(("guile" ,guile-2.2) + ("guile-commonmark" ,guile-commonmark) + ("guile-json" ,guile-json))) + (home-page "https://github.com/UMCUGenetics/hpcguix-web") + (synopsis "Web interface for cluster deployments of Guix") + (description "Hpcguix-web provides a web interface to the list of packages +provided by Guix. The list of packages is searchable and provides +instructions on how to use Guix in a shared HPC environment.") + (license l:agpl3+)))) -- cgit v1.2.3 From 93b83eb31e35aedaafcc40cfbb9a8743e0f6352d Mon Sep 17 00:00:00 2001 From: Rouby Pierre-Antoine Date: Wed, 30 May 2018 11:47:04 +0200 Subject: 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 @@ php-fpm-service-type nginx-php-location - cat-avatar-generator-service)) + cat-avatar-generator-service + + hpcguix-web-configuration + hpcguix-web-configuration? + hpcguix-web-service-type)) ;;; Commentary: ;;; @@ -893,3 +901,65 @@ a webserver.") (nginx-server-configuration-locations configuration))) (root #~(string-append #$package "/share/web/cat-avatar-generator")))))) + + +(define-record-type* + hpcguix-web-configuration 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 @@ #:use-module (guix store) #:export (%test-httpd %test-nginx - %test-php-fpm)) + %test-php-fpm + %test-hpcguix-web)) (define %index.html-contents ;; Contents of the /index.html file. @@ -281,3 +283,81 @@ HTTP-PORT, along with php-fpm." (name "php-fpm") (description "Test PHP-FPM through nginx.") (value (run-php-fpm-test)))) + + +;;; +;;; hpcguix-web +;;; + +(define* (run-hpcguix-web-server-test name test-os) + "Run tests in %HPCGUIX-WEB-OS, which has hpcguix-web running." + (define os + (marionette-operating-system + test-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings '((8080 . 5000))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (web uri) + (web client) + (web response)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin #$name) + + (test-assert "hpcguix-web running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'hpcguix-web) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-equal "http-get" + 200 + (begin + (wait-for-tcp-port 5000 marionette) + (let-values (((response text) + (http-get "http://localhost:8080"))) + (response-code response)))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation (string-append name "-test") test)) + +(define %hpcguix-web-specs + ;; Server config gexp. + #~(define site-config + (hpcweb-configuration + (title-prefix "[TEST] HPCGUIX-WEB")))) + +(define %hpcguix-web-os + (simple-operating-system + (dhcp-client-service) + (service hpcguix-web-service-type + (hpcguix-web-configuration + (specs %hpcguix-web-specs))))) + +(define %test-hpcguix-web + (system-test + (name "hpcguix-web") + (description "Connect to a running hpcguix-web server.") + (value (run-hpcguix-web-server-test name %hpcguix-web-os)))) -- cgit v1.2.3 From 4c798726b45d892edc278f0b32462abed7742f8e Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Feb 2018 12:58:48 -0500 Subject: 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 @@ vector types are supported. Specific instances are provided for unboxed, boxed and storable vectors.") (license license:bsd-3))) +(define-public ghc-bloomfilter + (package + (name "ghc-bloomfilter") + (version "2.0.1.0") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "bloomfilter/bloomfilter-" version ".tar.gz")) + (sha256 + (base32 + "03vrmncg1c10a2wcg5skq30m1yiknn7nwxz2gblyyfaxglshspkc")))) + (build-system haskell-build-system) + (native-inputs + `(("ghc-quickcheck" ,ghc-quickcheck) + ("ghc-random" ,ghc-random) + ("ghc-test-framework" ,ghc-test-framework) + ("ghc-test-framework-quickcheck2" ,ghc-test-framework-quickcheck2))) + (home-page "https://github.com/bos/bloomfilter") + (synopsis "Pure and impure Bloom filter implementations") + (description "This package provides both mutable and immutable Bloom +filter data types, along with a family of hash functions and an easy-to-use +interface.") + (license license:bsd-3))) + (define-public ghc-network (package (name "ghc-network") -- cgit v1.2.3 From e3aae496f9965ba4dd6137bdefcbdfea42af7faa Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Feb 2018 19:07:44 -0500 Subject: 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 @@ online}.") (description "This package provides a simple XML library for Haskell.") (license license:bsd-3))) +(define-public ghc-feed + (package + (name "ghc-feed") + (version "0.3.12.0") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "feed/feed-" version ".tar.gz")) + (sha256 + (base32 + "0hkrsinspg70bbm3hwqdrvivws6zya1hyk0a3awpaz82j4xnlbfc")))) + (build-system haskell-build-system) + (inputs + `(("ghc-old-locale" ,ghc-old-locale) + ("ghc-old-time" ,ghc-old-time) + ("ghc-time-locale-compat" ,ghc-time-locale-compat) + ("ghc-utf8-string" ,ghc-utf8-string) + ("ghc-xml" ,ghc-xml))) + (native-inputs + `(("ghc-hunit" ,ghc-hunit) + ("ghc-test-framework" ,ghc-test-framework) + ("ghc-test-framework-hunit" ,ghc-test-framework-hunit))) + (home-page "https://github.com/bergmark/feed") + (synopsis "Haskell package for handling various syndication formats") + (description "This Haskell package includes tools for generating and +consuming feeds in both RSS (Really Simple Syndication) and Atom format.") + (license license:bsd-3))) + (define-public ghc-exceptions (package (name "ghc-exceptions") -- cgit v1.2.3 From a39e6faee9826ca473a0fdb8139a2fede25638d1 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Mon, 19 Feb 2018 19:08:28 -0500 Subject: 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 @@ with various performance characteristics.") manipulating monad transformer stacks.") (license license:bsd-3))) +(define-public ghc-ifelse + (package + (name "ghc-ifelse") + (version "0.85") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "IfElse/IfElse-" version ".tar.gz")) + (sha256 + (base32 + "1kfx1bwfjczj93a8yqz1n8snqiq5655qgzwv1lrycry8wb1vzlwa")))) + (build-system haskell-build-system) + (inputs `(("ghc-mtl" ,ghc-mtl))) + (home-page "http://hackage.haskell.org/package/IfElse") + (synopsis "Monadic control flow with anaphoric variants") + (description "This library provides functions for control flow inside of +monads with anaphoric variants on @code{if} and @code{when} and a C-like +@code{switch} function.") + (license license:bsd-3))) + (define-public ghc-monad-control (package (name "ghc-monad-control") -- cgit v1.2.3 From 92c2097bc28a4f9d564805c18b102be9c745f10e Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 00:12:21 -0500 Subject: 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 @@ converting between Haskell values and JSON. JSON (JavaScript Object Notation) is a lightweight data-interchange format.") (license license:bsd-3))) +(define-public ghc-esqueleto + (package + (name "ghc-esqueleto") + (version "2.5.3") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "esqueleto/esqueleto-" version ".tar.gz")) + (sha256 + (base32 + "10n49rzqmblky7pwjnysalyy6nacmxfms8dqbsdv6hlyzr8pb69x")))) + (build-system haskell-build-system) + (inputs + `(("ghc-blaze-html" ,ghc-blaze-html) + ("ghc-conduit" ,ghc-conduit) + ("ghc-monad-logger" ,ghc-monad-logger) + ("ghc-persistent" ,ghc-persistent) + ("ghc-resourcet" ,ghc-resourcet) + ("ghc-tagged" ,ghc-tagged) + ("ghc-text" ,ghc-text) + ("ghc-unordered-containers" ,ghc-unordered-containers))) + (native-inputs + `(("ghc-hspec" ,ghc-hspec) + ("ghc-hunit" ,ghc-hunit) + ("ghc-monad-control" ,ghc-monad-control) + ("ghc-persistent-sqlite" ,ghc-persistent-sqlite) + ("ghc-persistent-template" ,ghc-persistent-template) + ("ghc-quickcheck" ,ghc-quickcheck))) + (home-page "https://github.com/bitemyapp/esqueleto") + (synopsis "Type-safe embedded domain specific language for SQL queries") + (description "This library provides a type-safe embedded domain specific +language (EDSL) for SQL queries that works with SQL backends as provided by +@code{ghc-persistent}. Its language closely resembles SQL, so you don't have +to learn new concepts, just new syntax, and it's fairly easy to predict the +generated SQL and optimize it for your backend.") + (license license:bsd-3))) + (define-public shellcheck (package (name "shellcheck") -- cgit v1.2.3 From 6950a4507392bec54ad84378dd0a2c2904238f65 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 00:25:04 -0500 Subject: 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 @@ case with other forms of concurrent communication, such as locks or "This package provides a library for parallel programming.") (license license:bsd-3))) +(define-public ghc-safesemaphore + (package + (name "ghc-safesemaphore") + (version "0.10.1") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "SafeSemaphore/SafeSemaphore-" version ".tar.gz")) + (sha256 + (base32 + "0rpg9j6fy70i0b9dkrip9d6wim0nac0snp7qzbhykjkqlcvvgr91")))) + (build-system haskell-build-system) + (inputs + `(("ghc-stm" ,ghc-stm))) + (native-inputs + `(("ghc-hunit" ,ghc-hunit))) + (home-page "https://github.com/ChrisKuklewicz/SafeSemaphore") + (synopsis "Exception safe semaphores") + (description "This library provides exception safe semaphores that can be +used in place of @code{QSem}, @code{QSemN}, and @code{SampleVar}, all of which +are not exception safe and can be broken by @code{killThread}.") + (license license:bsd-3))) + (define-public ghc-text (package (name "ghc-text") -- cgit v1.2.3 From 1ea3971992068944977cb031cc6b21018bdd001e Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 02:56:58 -0500 Subject: 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 @@ bytestrings and their hexademical representation.") (base32 "0n39s1i88j6s7vvsdhpbhcr3gpbwlzabwcc3nbd7nqb4kb4i0sls")))) (build-system haskell-build-system) + (arguments + `(#:configure-flags (list "--allow-newer=QuickCheck"))) (inputs `(("ghc-hashable" ,ghc-hashable))) (native-inputs -- cgit v1.2.3 From 4e5d9bf20ecd8c888956c029fa5c47a74182b347 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 20 Feb 2018 23:13:57 -0500 Subject: 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 @@ serialization code.") (home-page "https://hackage.haskell.org/package/bytes") (license license:bsd-3))) +(define-public ghc-disk-free-space + (package + (name "ghc-disk-free-space") + (version "0.1.0.1") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "disk-free-space/disk-free-space-" + version ".tar.gz")) + (sha256 + (base32 + "07rqj8k1vh3cykq9yidpjxhgh1f7vgmjs6y1nv5kq2217ff4yypi")))) + (build-system haskell-build-system) + (home-page "https://github.com/redneb/disk-free-space") + (synopsis "Retrieve information about disk space usage") + (description "A cross-platform library for retrieving information about +disk space usage.") + (license license:bsd-3))) + ;;; haskell.scm ends here -- cgit v1.2.3 From a078a6ec3bbc75d0765c63530e8d6b783d8b3949 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Tue, 29 May 2018 12:07:54 -0400 Subject: 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 @@ #: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 @@ venerable RCS, hence the anagrammatic acronym. The design is tuned for use cases like all those little scripts in your @file{~/bin} directory, or a directory full of HOWTOs.") (license license:bsd-2))) + +(define-public git-annex + (package + (name "git-annex") + (version "6.20170818") + (source + (origin + (method url-fetch) + (uri (string-append "https://hackage.haskell.org/package/" + "git-annex/git-annex-" version ".tar.gz")) + (sha256 + (base32 + "0ybxixbqvy4rx6mq9s02rh349rbr04hb17z4bfayin0qwa5kzpvx")))) + (build-system haskell-build-system) + (arguments + `(#:configure-flags + '("--flags=-Android -Assistant -Pairing -S3 -Webapp -WebDAV") + #:phases + (modify-phases %standard-phases + (add-before 'configure 'patch-shell + (lambda _ + (substitute* "Utility/Shell.hs" + (("/bin/sh") (which "sh"))) + #t)) + (add-before 'configure 'factor-setup + (lambda _ + ;; Factor out necessary build logic from the provided + ;; `Setup.hs' script. The script as-is does not work because + ;; it cannot find its dependencies, and there is no obvious way + ;; to tell it where to look. Note that we do not preserve the + ;; code that installs man pages here. + (call-with-output-file "PreConf.hs" + (lambda (out) + (format out "import qualified Build.Configure as Configure~%") + (format out "main = Configure.run Configure.tests~%"))) + (call-with-output-file "Setup.hs" + (lambda (out) + (format out "import Distribution.Simple~%") + (format out "main = defaultMain~%"))) + #t)) + (add-before 'configure 'pre-configure + (lambda _ + (invoke "runhaskell" "PreConf.hs") + #t)) + (replace 'check + (lambda _ + ;; We need to set the path so that Git recognizes + ;; `git annex' as a custom command. + (setenv "PATH" (string-append (getenv "PATH") ":" + (getcwd) "/dist/build/git-annex")) + (with-directory-excursion "dist/build/git-annex" + (symlink "git-annex" "git-annex-shell")) + (invoke "git-annex" "test") + #t)) + (add-after 'install 'install-symlinks + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin"))) + (symlink (string-append bin "/git-annex") + (string-append bin "/git-annex-shell")) + (symlink (string-append bin "/git-annex") + (string-append bin "/git-remote-tor-annex")) + #t)))))) + (inputs + `(("curl" ,curl) + ("ghc-aeson" ,ghc-aeson) + ("ghc-async" ,ghc-async) + ("ghc-bloomfilter" ,ghc-bloomfilter) + ("ghc-byteable" ,ghc-byteable) + ("ghc-case-insensitive" ,ghc-case-insensitive) + ("ghc-crypto-api" ,ghc-crypto-api) + ("ghc-cryptonite" ,ghc-cryptonite) + ("ghc-data-default" ,ghc-data-default) + ("ghc-disk-free-space" ,ghc-disk-free-space) + ("ghc-dlist" ,ghc-dlist) + ("ghc-edit-distance" ,ghc-edit-distance) + ("ghc-esqueleto" ,ghc-esqueleto) + ("ghc-exceptions" ,ghc-exceptions) + ("ghc-feed" ,ghc-feed) + ("ghc-free" ,ghc-free) + ("ghc-hslogger" ,ghc-hslogger) + ("ghc-http-client" ,ghc-http-client) + ("ghc-http-conduit" ,ghc-http-conduit) + ("ghc-http-types" ,ghc-http-types) + ("ghc-ifelse" ,ghc-ifelse) + ("ghc-memory" ,ghc-memory) + ("ghc-monad-control" ,ghc-monad-control) + ("ghc-monad-logger" ,ghc-monad-logger) + ("ghc-mtl" ,ghc-mtl) + ("ghc-network" ,ghc-network) + ("ghc-old-locale" ,ghc-old-locale) + ("ghc-optparse-applicative" ,ghc-optparse-applicative) + ("ghc-persistent" ,ghc-persistent) + ("ghc-persistent-sqlite" ,ghc-persistent-sqlite) + ("ghc-persistent-template" ,ghc-persistent-template) + ("ghc-quickcheck" ,ghc-quickcheck) + ("ghc-random" ,ghc-random) + ("ghc-regex-tdfa" ,ghc-regex-tdfa) + ("ghc-resourcet" ,ghc-resourcet) + ("ghc-safesemaphore" ,ghc-safesemaphore) + ("ghc-sandi" ,ghc-sandi) + ("ghc-securemem" ,ghc-securemem) + ("ghc-socks" ,ghc-socks) + ("ghc-split" ,ghc-split) + ("ghc-stm" ,ghc-stm) + ("ghc-stm-chans" ,ghc-stm-chans) + ("ghc-text" ,ghc-text) + ("ghc-unix-compat" ,ghc-unix-compat) + ("ghc-unordered-containers" ,ghc-unordered-containers) + ("ghc-utf8-string" ,ghc-utf8-string) + ("ghc-uuid" ,ghc-uuid) + ("git" ,git) + ("rsync" ,rsync))) + (native-inputs + `(("ghc-tasty" ,ghc-tasty) + ("ghc-tasty-hunit" ,ghc-tasty-hunit) + ("ghc-tasty-quickcheck" ,ghc-tasty-quickcheck) + ("ghc-tasty-rerun" ,ghc-tasty-rerun))) + (home-page "https://git-annex.branchable.com/") + (synopsis "Manage files with Git, without checking in their contents") + (description "This package allows managing files with Git, without +checking the file contents into Git. It can store files in many places, +such as local hard drives and cloud storage services. It can also be +used to keep a folder in sync between computers.") + ;; The web app is released under the AGPLv3+. + (license (list license:gpl3+ + license:agpl3+)))) -- cgit v1.2.3 From 514026d7de36b299238aff9dfcc2f898fb04072a Mon Sep 17 00:00:00 2001 From: Robin Templeton Date: Tue, 29 May 2018 12:02:41 -0400 Subject: 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 @@ (package (name "rust-bootstrap") (version "1.22.1") - (source (origin - (method url-fetch) - (uri (string-append - "https://static.rust-lang.org/dist/" - "rust-" version "-" %host-type ".tar.gz")) - (sha256 - (base32 - (match %host-type - ("i686-unknown-linux-gnu" - "15zqbx86nm13d5vq2gm69b7av4vg479f74b5by64hs3bcwwm08pr") - ("x86_64-unknown-linux-gnu" - "1yll78x6b3abnvgjf2b66gvp6mmcb9y9jdiqcwhmgc0z0i0fix4c") - ("armv7-unknown-linux-gnueabihf" - "138a8l528kzp5wyk1mgjaxs304ac5ms8vlpq0ggjaznm6bn2j7a5") - ("aarch64-unknown-linux-gnu" - "0z6m9m1rx4d96nvybbfmpscq4dv616m615ijy16d5wh2vx0p4na8") - ("mips64el-unknown-linux-gnuabi64" - "07k4pcv7jvfa48cscdj8752lby7m7xdl88v3a6na1vs675lhgja2") - (_ "")))))) + (source #f) (build-system gnu-build-system) (native-inputs `(("patchelf" ,patchelf))) (inputs `(("gcc" ,(canonical-package gcc)) ("gcc:lib" ,(canonical-package gcc) "lib") - ("zlib" ,zlib))) + ("zlib" ,zlib) + ("source" + ,(origin + (method url-fetch) + (uri (string-append + "https://static.rust-lang.org/dist/" + "rust-" version "-" (nix-system->gnu-triplet) ".tar.gz")) + (sha256 + (base32 + (match (nix-system->gnu-triplet) + ("i686-unknown-linux-gnu" + "15zqbx86nm13d5vq2gm69b7av4vg479f74b5by64hs3bcwwm08pr") + ("x86_64-unknown-linux-gnu" + "1yll78x6b3abnvgjf2b66gvp6mmcb9y9jdiqcwhmgc0z0i0fix4c") + ("armv7-unknown-linux-gnueabihf" + "138a8l528kzp5wyk1mgjaxs304ac5ms8vlpq0ggjaznm6bn2j7a5") + ("aarch64-unknown-linux-gnu" + "0z6m9m1rx4d96nvybbfmpscq4dv616m615ijy16d5wh2vx0p4na8") + ("mips64el-unknown-linux-gnuabi64" + "07k4pcv7jvfa48cscdj8752lby7m7xdl88v3a6na1vs675lhgja2") + (_ "")))))))) (outputs '("out" "cargo")) (arguments `(#:tests? #f @@ -117,7 +119,7 @@ (invoke "bash" "install.sh" (string-append "--prefix=" out) (string-append "--components=rustc," - "rust-std-" %host-type)) + "rust-std-" ,(nix-system->gnu-triplet))) ;; Instal cargo (invoke "bash" "install.sh" (string-append "--prefix=" cargo-out) @@ -196,6 +198,12 @@ in turn be used to build the final Rust.") ;; This test is known to fail on aarch64 and powerpc64le: ;; https://github.com/rust-lang/rust/issues/45410 (("fn test_loading_cosine") "#[ignore]\nfn test_loading_cosine")) + ;; nm doesn't recognize the file format because of the + ;; nonstandard sections used by the Rust compiler, but readelf + ;; ignores them. + (substitute* "src/test/run-make/atomic-lock-free/Makefile" + (("\tnm ") + "\treadelf -c ")) #t))) (add-after 'patch-source-shebangs 'patch-cargo-checksums (lambda* _ @@ -386,6 +394,10 @@ safety and thread safety guarantees.") (substitute* "src/tools/cargo/tests/death.rs" ;; This is stuck when built in container. (("fn ctrl_c_kills_everyone") "#[ignore]\nfn ctrl_c_kills_everyone")) + ;; Prints test output in the wrong order when built on + ;; i686-linux. + (substitute* "src/tools/cargo/tests/test.rs" + (("fn cargo_test_env") "#[ignore]\nfn cargo_test_env")) #t)) (add-after 'patch-cargo-tests 'fix-mtime-bug (lambda* _ @@ -433,7 +445,7 @@ rpath = true # codegen/mainsubprogram.rs and codegen/mainsubprogramstart.rs # This tests required patched LLVM codegen-tests = false -[target." %host-type "] +[target." ,(nix-system->gnu-triplet) "] llvm-config = \"" llvm "/bin/llvm-config" "\" cc = \"" gcc "/bin/gcc" "\" cxx = \"" gcc "/bin/g++" "\" @@ -456,8 +468,10 @@ jemalloc = \"" jemalloc "/lib/libjemalloc_pic.a" "\" (invoke "./x.py" "build" "src/tools/cargo"))) (replace 'check (lambda* _ - (invoke "./x.py" "test") - (invoke "./x.py" "test" "src/tools/cargo"))) + ;; Disable parallel execution to prevent EAGAIN errors when + ;; running tests. + (invoke "./x.py" "-j1" "test") + (invoke "./x.py" "-j1" "test" "src/tools/cargo"))) (replace 'install (lambda* (#:key outputs #:allow-other-keys) (invoke "./x.py" "install") -- cgit v1.2.3 From 5d669883ecc104403c5d3ba7d172e9c02234577c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 13:45:36 +0200 Subject: 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 @@ last one is created from the given object." "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 @@ they can refer to each other." %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))))) -- cgit v1.2.3 From 44057a461b1fa8102938c4e0f54d7cbc9dd09b03 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 30 May 2018 09:55:28 +0200 Subject: 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 @@ #: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"))) -- cgit v1.2.3 From ccc951cab3172adfdaf6fd2dfa8f8cdb98358a69 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 15:17:41 +0200 Subject: 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 @@ #: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)))) -- cgit v1.2.3 From 838e17d8050236a6d3ffde991fb0035412eb3046 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:14:37 +0200 Subject: 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 @@ #:export (gexp gexp? with-imported-modules + with-extensions gexp-input gexp-input? @@ -118,10 +119,11 @@ ;; "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 @@ whether this should be considered a \"native\" input or not." (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 @@ false, meaning that GEXP is a plain Scheme object, return the empty list." (gexp-references gexp)))) '())) ;plain Scheme data type +(define (gexp-modules gexp) + "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is +false, meaning that GEXP is a plain Scheme object, return the empty list." + (gexp-attribute gexp gexp-self-modules)) + +(define (gexp-extensions gexp) + "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? +GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty +list." + (gexp-attribute gexp gexp-self-extensions)) + (define* (lower-inputs inputs #:key system target) "Turn any package from INPUTS into a derivation for SYSTEM; return the @@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to (modules '()) (module-path %load-path) (guile-for-build (%guile-for-build)) + (effective-version "2.2") (graft? (%graft?)) references-graphs allowed-references disallowed-references @@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). +EFFECTIVE-VERSION determines the string to use when adding extensions of +EXP (see 'with-extensions') to the search path---e.g., \"2.2\". + GRAFT? determines whether packages referred to by EXP should be grafted when applicable. @@ -630,7 +648,7 @@ The other arguments are as for 'derivation'." (define (graphs-file-names graphs) ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. (map (match-lambda - ;; TODO: Remove 'derivation?' special cases. + ;; TODO: Remove 'derivation?' special cases. ((file-name (? derivation? drv)) (cons file-name (derivation->output-path drv))) ((file-name (? derivation? drv) sub-drv) @@ -639,7 +657,13 @@ The other arguments are as for 'derivation'." (cons file-name thing))) graphs)) - (mlet* %store-monad (;; The following binding forces '%current-system' and + (define (extension-flags extension) + `("-L" ,(string-append (derivation->output-path extension) + "/share/guile/site/" effective-version) + "-C" ,(string-append (derivation->output-path extension) + "/lib/guile/" effective-version "/site-ccache"))) + + (mlet* %store-monad ( ;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= ;; time. (graft? (set-grafting graft?)) @@ -660,6 +684,11 @@ The other arguments are as for 'derivation'." #:target target)) (builder (text-file script-name (object->string sexp))) + (extensions -> (gexp-extensions exp)) + (exts (mapm %store-monad + (lambda (obj) + (lower-object obj system)) + extensions)) (modules (if (pair? %modules) (imported-modules %modules #:system system @@ -672,6 +701,7 @@ The other arguments are as for 'derivation'." (compiled-modules %modules #:system system #:module-path module-path + #:extensions extensions #:guile guile-for-build #:deprecation-warnings deprecation-warnings) @@ -704,6 +734,7 @@ The other arguments are as for 'derivation'." `("-L" ,(derivation->output-path modules) "-C" ,(derivation->output-path compiled)) '()) + ,@(append-map extension-flags exts) ,builder) #:outputs outputs #:env-vars env-vars @@ -713,6 +744,7 @@ The other arguments are as for 'derivation'." ,@(if modules `((,modules) (,compiled) ,@inputs) inputs) + ,@(map list exts) ,@(match graphs (((_ . inputs) ...) inputs) (_ '()))) @@ -861,6 +893,17 @@ environment." (identifier-syntax modules))) body ...)) +(define-syntax-parameter current-imported-extensions + ;; Current list of extensions. + (identifier-syntax '())) + +(define-syntax-rule (with-extensions extensions body ...) + "Mark the gexps defined in BODY... as requiring EXTENSIONS in their +execution environment." + (syntax-parameterize ((current-imported-extensions + (identifier-syntax extensions))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -957,6 +1000,7 @@ environment." (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) current-imported-modules + current-imported-extensions (lambda #,formals #,sexp))))))) @@ -1071,6 +1115,7 @@ last one is created from the given object." (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) + (extensions '()) (deprecation-warnings #f)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where @@ -1129,6 +1174,26 @@ they can refer to each other." (@ (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 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2)) -(define* (load-path-expression modules #:optional (path %load-path)) +(define* (load-path-expression modules #:optional (path %load-path) + #:key (extensions '())) "Return as a monadic value a gexp that sets '%load-path' and '%load-compiled-path' to point to MODULES, a list of module names. MODULES are searched for in PATH." (mlet %store-monad ((modules (imported-modules modules #:module-path path)) (compiled (compiled-modules modules + #:extensions extensions #:module-path path))) (return (gexp (eval-when (expand load eval) (set! %load-path - (cons (ungexp modules) %load-path)) + (cons (ungexp modules) + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + '((ungexp-native-splicing extensions))) + %load-path))) (set! %load-compiled-path (cons (ungexp compiled) - %load-compiled-path))))))) + (append (map (lambda (extension) + (string-append extension + "/lib/guile/" + (effective-version) + "/site-ccache")) + '((ungexp-native-splicing extensions))) + %load-compiled-path)))))))) (define* (gexp->script name exp #:key (guile (default-guile)) @@ -1196,7 +1275,9 @@ are searched for in PATH." imported modules in its search path. Look up EXP's modules in MODULE-PATH." (mlet %store-monad ((set-load-path (load-path-expression (gexp-modules exp) - module-path))) + module-path + #:extensions + (gexp-extensions exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1225,35 +1306,38 @@ the resulting file. When SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' and '%load-compiled-path' to honor EXP's imported modules. Lookup EXP's modules in MODULE-PATH." - (match (if set-load-path? (gexp-modules exp) '()) - (() ;zero modules - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (for-each (lambda (exp) - (write exp port)) - '(ungexp (if splice? - exp - (gexp ((ungexp exp))))))))) - #:local-build? #t - #:substitutable? #f)) - ((modules ...) - (mlet %store-monad ((set-load-path (load-path-expression modules - module-path))) - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp set-load-path) port) - (for-each (lambda (exp) - (write exp port)) - '(ungexp (if splice? - exp - (gexp ((ungexp exp))))))))) - #:module-path module-path - #:local-build? #t - #:substitutable? #f))))) + (define modules (gexp-modules exp)) + (define extensions (gexp-extensions exp)) + + (if (or (not set-load-path?) + (and (null? modules) (null? extensions))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (for-each (lambda (exp) + (write exp port)) + '(ungexp (if splice? + exp + (gexp ((ungexp exp))))))))) + #:local-build? #t + #:substitutable? #f) + (mlet %store-monad ((set-load-path + (load-path-expression modules module-path + #:extensions extensions))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (for-each (lambda (exp) + (write exp port)) + '(ungexp (if splice? + exp + (gexp ((ungexp exp))))))))) + #:module-path module-path + #:local-build? #t + #:substitutable? #f)))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing 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 @@ #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix build-system trivial) #:use-module (guix tests) #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) @@ -66,6 +67,27 @@ (run-with-store %store exp #:guile-for-build (%guile-for-build)))) +(define %extension-package + ;; Example of a package to use when testing 'with-extensions'. + (dummy-package "extension" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let* ((out (string-append (assoc-ref %outputs "out") + "/share/guile/site/" + (effective-version)))) + (mkdir-p out) + (call-with-output-file (string-append out "/hg2g.scm") + (lambda (port) + (write '(define-module (hg2g) + #:export (the-answer)) + port) + (write '(define the-answer 42) port))))))))) + (test-begin "gexp") @@ -739,6 +761,54 @@ (built-derivations (list drv)) (return (= 42 (call-with-input-file out read)))))) +(test-equal "gexp-extensions & ungexp" + (list sed grep) + ((@@ (guix gexp) gexp-extensions) + #~(foo #$(with-extensions (list grep) #~+) + #+(with-extensions (list sed) #~-)))) + +(test-equal "gexp-extensions & ungexp-splicing" + (list grep sed) + ((@@ (guix gexp) gexp-extensions) + #~(foo #$@(list (with-extensions (list grep) #~+) + (with-imported-modules '((foo)) + (with-extensions (list sed) #~-)))))) + +(test-equal "gexp-extensions and literal Scheme object" + '() + ((@@ (guix gexp) gexp-extensions) #t)) + +(test-assertm "gexp->derivation & with-extensions" + ;; Create a fake Guile extension and make sure it is accessible both to the + ;; imported modules and to the derivation build script. + (mlet* %store-monad + ((extension -> %extension-package) + (module -> (scheme-file "x" #~( ;; splice! + (define-module (foo) + #:use-module (hg2g) + #:export (multiply)) + + (define (multiply x) + (* the-answer x))) + #:splice? #t)) + (build -> (with-extensions (list extension) + (with-imported-modules `((guix build utils) + ((foo) => ,module)) + #~(begin + (use-modules (guix build utils) + (hg2g) (foo)) + (call-with-output-file #$output + (lambda (port) + (write (list the-answer (multiply 2)) + port))))))) + (drv (gexp->derivation "thingie" build + ;; %BOOTSTRAP-GUILE is 2.0. + #:effective-version "2.0")) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (equal? '(42 84) (call-with-input-file out read)))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) @@ -948,6 +1018,22 @@ (return (and (zero? (close-pipe pipe)) (string=? text str)))))))))) +(test-assertm "program-file & with-extensions" + (let* ((exp (with-extensions (list %extension-package) + (gexp (begin + (use-modules (hg2g)) + (display the-answer))))) + (file (program-file "program" exp + #:guile %bootstrap-guile))) + (mlet* %store-monad ((drv (lower-object file)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= 42 (string->number str))))))))) + (test-assertm "scheme-file" (let* ((text (plain-file "foo" "Hello, world!")) (scheme (scheme-file "bar" #~(list "foo" #$text)))) -- cgit v1.2.3 From 13993c77fec7580f4f10ea07256db9e5f5a7949b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:22:24 +0200 Subject: 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 | 41 +++++++++++++++++++---------------------- 2 files changed, 21 insertions(+), 26 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 @@ delete-file-recursively with-directory-excursion invoke)) + #:use-module (json) ;guile-json #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module ((texinfo string-utils) @@ -34,9 +35,6 @@ #:use-module (ice-9 match) #:export (build-docker-image)) -;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co. -(module-use! (current-module) (resolve-interface '(json))) - ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. (define docker-id (compose bytevector->base16-string sha256 string->utf8)) 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 @@ the image." guile-json)) (define build - (with-imported-modules `(,@(source-module-closure '((guix docker)) - #:select? not-config?) - (guix build store-copy) - ((guix config) => ,config)) - #~(begin - ;; Guile-JSON is required by (guix docker). - (add-to-load-path - (string-append #+json "/share/guile/site/" - (effective-version))) - - (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) - - (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))))) + ;; 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)) + + (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)))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) -- cgit v1.2.3 From ff913cf514b2a1d6d8400b24c675125387049b41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:23:24 +0200 Subject: 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 | 290 ++++++++++++++++++++++++++---------------------------- 1 file changed, 142 insertions(+), 148 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 @@ When SFTP? is true, run an SFTP server test." (define test (with-imported-modules '((gnu build marionette)) - #~(begin - (eval-when (expand load eval) - ;; Prepare to use Guile-SSH. - (set! %load-path - (cons (string-append #+guile-ssh "/share/guile/site/" - (effective-version)) - %load-path))) - - (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 (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 + (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)) + + (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 (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))))) - - (define (call-with-connected-session/auth proc) - "Make an authenticated session. We should be able to connect as + (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 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))))))))) - - (mkdir #$output) - (chdir #$output) - - (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)) - - ;; 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)) - - ;; 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 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)))))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + (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) + + (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)) + + ;; 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)) + + ;; 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 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)))))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0)))))) (gexp->derivation name test)) -- cgit v1.2.3 From 31a5d694a3b9200bfde253eafbaca118b773fb96 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 18:27:07 +0200 Subject: bootloader: grub: Simplify 'svg->png'. * gnu/bootloader/grub.scm (svg->png): Remove now unneeded #:guile-for-build argument. --- gnu/bootloader/grub.scm | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 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 @@ otherwise." (define* (svg->png svg #:key width height) "Build a PNG of HEIGHT x WIDTH from SVG." - ;; Note: Guile-RSVG & co. are now built for Guile 2.2, so we use 2.2 here. - ;; TODO: Remove #:guile-for-build when 2.2 has become the default. - (mlet %store-monad ((guile (package->derivation guile-2.2 #:graft? #f))) - (gexp->derivation "grub-image.png" - (with-imported-modules '((gnu build svg)) - #~(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))) + (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))))) (define* (grub-background-image config #:key (width 1024) (height 768)) "Return the GRUB background image defined in CONFIG with a ratio of -- cgit v1.2.3 From 33d8a871042e73d6b236793d02e5a8287a47ebe4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 21:47:01 +0200 Subject: 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 @@ otherwise." "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 -- cgit v1.2.3 From 331ac4cc239727992329207ba428b3f26cae91d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 22:00:11 +0200 Subject: 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 | 68 +++++++++++++++++++++++++++---------------------------- 2 files changed, 35 insertions(+), 39 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 @@ ;;; ;;; 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 @@ the entries in MANIFEST." (define build (with-imported-modules modules - #~(begin - (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/" - (effective-version))) - - (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 man-directory - (string-append #$output "/share/man")) - - (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))))) + (with-extensions (list gdbm-ffi) ;for (guix man-db) + #~(begin + (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 man-directory + (string-append #$output "/share/man")) + + (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)))))) (gexp->derivation "manual-database" build -- cgit v1.2.3 From 9f160a0d3cc5f023dd65ba2bf47b4667196c7ca3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 May 2018 23:42:28 +0200 Subject: 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 | 95 +++++++++++++++++++++++++++---------------------------- 1 file changed, 47 insertions(+), 48 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 @@ should set REGISTER-CLOSURES? to #f." (eval-when (expand load eval) (define %libgcrypt #+(file-append libgcrypt "/lib/libgcrypt")))))) + (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (name -> (string-append name ".tar.gz")) (graph -> "system-graph")) (define build - (with-imported-modules `(,@(source-module-closure '((guix docker) - (guix build utils) - (gnu build vm)) - #:select? not-config?) - (guix build store-copy) - ((guix config) => ,config)) - #~(begin - ;; Guile-JSON is required by (guix docker). - (add-to-load-path - (string-append #+guile-json "/share/guile/site/" - (effective-version))) - (use-modules (guix docker) - (guix build utils) - (gnu build vm) - (srfi srfi-19) - (guix build store-copy)) - - (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 -> ""))))))) + (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 -> "")))))))) (expression->derivation-in-linux-vm name ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp -- cgit v1.2.3 From d59e75f3b5b82692bd250a1a3a9965397bb588c5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 May 2018 15:43:52 +0200 Subject: 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 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("guile-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 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) + ;; XXX: No "guile2.0-sqlite3". (_ #f)))) ;no such package @@ -216,11 +218,16 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." "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], -- cgit v1.2.3 From 7f9d184d9b688d13ce76eefabaddcfa76bdde2b5 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 19:19:30 +0200 Subject: 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 @@ %store-directory %state-directory + %store-database-directory %config-directory %guix-register-program @@ -80,6 +82,10 @@ (or (getenv "NIX_STATE_DIR") (string-append %localstatedir "/guix"))) +(define %store-database-directory + (or (and=> (getenv "NIX_DB_DIR") canonicalize-path) + (string-append %state-directory "/db"))) + (define %config-directory ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'. (or (getenv "GUIX_CONFIGURATION_DIRECTORY") 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") -- cgit v1.2.3 From 285cc75c3160421005ba0181490de4b290755b63 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 May 2018 21:32:17 +0200 Subject: 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 @@ #: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 @@ makes a wrapper around a port which implements GET-POSITION." (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 @@ be used internally by the daemon's build hook." (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 -- cgit v1.2.3 From bf5bf5778cb7c3a2475c6acd707abc925b1819aa Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Sun, 27 May 2018 23:20:54 +0200 Subject: 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 @@ #: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 @@ bytes of the store item denoted by PATH after being converted to nar form." ;;; 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 @@ it's a directory." (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 @@ be used internally by the daemon's build hook." #: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") -- cgit v1.2.3 From 65a9f6b6cf3e41a4bbb144d03c5c440dd01d25dc Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 1 Jun 2018 13:19:25 +0200 Subject: 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 @@ developers using C++ or QML, a CSS & JavaScript like language.") out "/share/doc/qt5/examples") "-opensource" "-confirm-license" + + ;; These features require higher versions of Linux than the + ;; minimum version of the glibc. See + ;; src/corelib/global/minimum-linux_p.h. By disabling these + ;; features Qt5 applications can be used on the oldest + ;; kernels that the glibc supports, including the RHEL6 + ;; (2.6.32) and RHEL7 (3.10) kernels. + "-no-feature-getentropy" ; requires Linux 3.17 + "-no-feature-renameat2" ; requires Linux 3.16 + ;; Do not build examples; if desired, these could go ;; into a separate output, but for the time being, we ;; prefer to save the space and build time. -- cgit v1.2.3 From 6d52844cd4c376b7b344b448de8a2c7a3d252afb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 17:31:44 +0200 Subject: 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 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("guile-gdbm-ffi" (ref '(gnu packages guile) 'guile-gdbm-ffi)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) @@ -93,6 +94,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) + ("guile2.0-gdbm-ffi" (ref '(gnu packages guile) 'guile2.0-gdbm-ffi)) ;; XXX: No "guile2.0-sqlite3". (_ #f)))) ;no such package @@ -217,6 +219,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." "guile-git" "guile2.0-git")) + (define guile-gdbm-ffi + (package-for-guile guile-version + "guile-gdbm-ffi" + "guile2.0-gdbm-ffi")) + (define guile-sqlite3 (package-for-guile guile-version @@ -227,7 +234,8 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (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))) -- cgit v1.2.3 From 54be2b4d759c9e40c5b564726f882470bbac4387 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Jun 2018 18:36:28 +0200 Subject: 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 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." `(#:local-build? #f ;allow substitutes ;; Don't annoy people about _IONBF deprecation. - #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) + ;; Initialize 'terminal-width' in (system repl debug) + ;; to a large-enough value to make backtrace more + ;; verbose. + #:env-vars (("GUILE_WARN_DEPRECATED" . "no") + ("COLUMNS" . "200"))))) ;;; -- cgit v1.2.3 From 1a3e3162acafd32ff2fb675f2f780d986692c52d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 1 Jun 2018 02:20:03 -0400 Subject: 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 @@ security standards.") (mozilla-patch "icecat-bug-1459206-pt2.patch" "9ad16112044a" "0ayya67sx7avcb8bplfdxb92l9g4mjrb1s3hby283llhqv0ikg9b") (mozilla-patch "icecat-bug-1459162.patch" "11d8a87fb6d6" "1rkmdk18llw0x1jakix75hlhy0hpsmlminnflagbzrzjli81gwm1") (mozilla-patch "icecat-bug-1451297.patch" "407b10ad1273" "16qzsfirw045xag96f1qvpdlibm8lwdj9l1mlli4n1vz0db91v9q") - (mozilla-patch "icecat-bug-1462682.patch" "e76e2e481b17" "0hnx13msjy28n3bpa2c24kpzalam4bdk5gnp0f9k671l48rs9yb3"))) + (mozilla-patch "icecat-bug-1462682.patch" "e76e2e481b17" "0hnx13msjy28n3bpa2c24kpzalam4bdk5gnp0f9k671l48rs9yb3") + (mozilla-patch "icecat-bug-1450688.patch" "2c75bfcd465c" "1pjinj8qypafqm2fk68s3hzcbzcijn09qzrpcxvzq6bl1yfc1xfd") + (mozilla-patch "icecat-bug-1456975.patch" "042f80f3befd" "0av918kin4bkrq7gnjz0h9w8kkq8rk9l93250lfl5kqrinza1gsk") + (mozilla-patch "icecat-bugs-1442722+1455071+1433642+1456604+1458320.patch" + "bb0451c9c4a0" "1lhm1b2a7c6jwhzsg3c830hfhp17p8j9zbcmgchpb8c5jkc3vw0x") + (mozilla-patch "icecat-bug-1465108-pt1.patch" "8189b262e3b9" "13rh86ddwmj1bhv3ibbil3sv5xbqq1c9v1czgbsna5hxxkzc1y3b") + (mozilla-patch "icecat-bug-1465108-pt2.patch" "9f81ae3f6e1d" "05vfg8a8jrzd93n1wvncmvdmqgf9cgsl8ryxgjs3032gbbjkga7q") + (mozilla-patch "icecat-bug-1459693.patch" "face7a3dd5d7" "0jclw30mf693w8lrmvn0iankggj21nh4j3zh51q5363rj5xncdzx") + (mozilla-patch "icecat-bug-1464829.patch" "7afb58c046c8" "1r0569r76712x7x1sw6xr0x06ilv6iw3fncb0f8r8b9mp6wrpx34") + (mozilla-patch "icecat-bug-1452375-pt1.patch" "f1a745f8c42d" "11q73pb7a8f09xjzil4rhg5nr49zrnz1vb0prni0kqvrnppf5s40") + (mozilla-patch "icecat-bug-1452375-pt2.patch" "1f9a430881cc" "0f79rv7njliqxx33z07n60b50jg0a596d1km7ayz2hivbl2d0168"))) (modules '((guix build utils))) (snippet '(begin -- cgit v1.2.3