From a387b0bebb151a766ca6a454a891f2370c96703c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 23 Sep 2018 22:24:07 +0200 Subject: store-copy: Display a progress bar when copying store items. * guix/build/store-copy.scm (populate-store): Add #:log-port parameter. Use 'progress-reporter/bar' to report progress. --- guix/build/store-copy.scm | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 2d9590d16f..64ade7885c 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -19,6 +19,7 @@ (define-module (guix build store-copy) #:use-module (guix build utils) #:use-module (guix sets) + #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -167,7 +168,8 @@ (define items (reduce + 0 (map file-size items))) -(define* (populate-store reference-graphs target) +(define* (populate-store reference-graphs target + #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." (define store @@ -183,9 +185,20 @@ (define (graph-from-file file) (mkdir-p store) (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append target thing))) - (things-to-copy))) + + (let* ((things (things-to-copy)) + (len (length things)) + (progress (progress-reporter/bar len + (format #f "copying ~a store items" + len) + log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing) + #:log (%make-void-port "w")) + (report)) + things))))) ;;; store-copy.scm ends here -- cgit v1.2.3 From 240a9c69a6064544a616acc521c993542c364948 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Sep 2018 15:08:38 +0200 Subject: perform-download: Optionally report a "download-progress" trace. * guix/scripts/perform-download.scm (perform-download): Add #:print-build-trace? and pass it to 'url-fetch'. (guix-perform-download): Define 'print-build-trace?' and pass it to 'perform-download'. * guix/build/download.scm (ftp-fetch): Add #:print-build-trace? and honor it. (url-fetch): Likewise. * nix/libstore/builtins.cc (builtinDownload): Set _NIX_OPTIONS environment variable. --- guix/build/download.scm | 33 ++++++++++++++++++++++----------- guix/scripts/perform-download.scm | 18 +++++++++++++----- nix/libstore/builtins.cc | 5 ++++- 3 files changed, 39 insertions(+), 17 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 315a3554ec..54163849a2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -115,7 +115,7 @@ (define (nar-uri-abbreviation uri) (string-drop path 33) path))) -(define* (ftp-fetch uri file #:key timeout) +(define* (ftp-fetch uri file #:key timeout print-build-trace?) "Fetch data from URI and write it to FILE. Return FILE on success. Bail out if the connection could not be established in less than TIMEOUT seconds." (let* ((conn (match (and=> (uri-userinfo uri) @@ -136,12 +136,17 @@ (define* (ftp-fetch uri file #:key timeout) (lambda (out) (dump-port* in out #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)))) - - (ftp-close conn)) - (newline) - file) + #:reporter + (if print-build-trace? + (progress-reporter/trace + file (uri->string uri) size) + (progress-reporter/file + (uri-abbreviation uri) size))))) + + (ftp-close conn) + (unless print-build-trace? + (newline)) + file)) ;; Autoload GnuTLS so that this module can be used even when GnuTLS is ;; not available. At compile time, this yields "possibly unbound @@ -723,7 +728,8 @@ (define* (url-fetch url file #:key (timeout 10) (verify-certificate? #t) (mirrors '()) (content-addressed-mirrors '()) - (hashes '())) + (hashes '()) + print-build-trace?) "Fetch FILE from URL; URL may be either a single string, or a list of string denoting alternate URLs for FILE. Return #f on failure, and FILE on success. @@ -759,13 +765,18 @@ (define (fetch uri file) (lambda (output) (dump-port* port output #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)) + #:reporter (if print-build-trace? + (progress-reporter/trace + file (uri->string uri) size) + (progress-reporter/file + (uri-abbreviation uri) size))) (newline))) file))) ((ftp) (false-if-exception* (ftp-fetch uri file - #:timeout timeout))) + #:timeout timeout + #:print-build-trace? + print-build-trace?))) (else (format #t "skipping URI with unsupported scheme: ~s~%" uri) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 9f6ecc00d2..df787a9940 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,14 +41,14 @@ (define %user-module (module-use! module (resolve-interface '(guix base32))) module)) -(define* (perform-download drv #:optional output) +(define* (perform-download drv #:optional output + #:key print-build-trace?) "Perform the download described by DRV, a fixed-output derivation, to OUTPUT. Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the actual output is different from that when we're doing a 'bmCheck' or 'bmRepair' build." - ;; TODO: Use 'trace-progress-proc' when possible. (derivation-let drv ((url "url") (output* "out") (executable "executable") @@ -68,6 +68,7 @@ (define* (perform-download drv #:optional output) ;; We're invoked by the daemon, which gives us write access to OUTPUT. (when (url-fetch url output + #:print-build-trace? print-build-trace? #:mirrors (if mirrors (call-with-input-file mirrors read) '()) @@ -99,6 +100,11 @@ (define (guix-perform-download . args) of GnuTLS over HTTPS, before we have built GnuTLS. See ." + (define print-build-trace? + (match (getenv "_NIX_OPTIONS") + (#f #f) + (str (string-contains str "print-extended-build-trace=1")))) + ;; This program must be invoked by guix-daemon under an unprivileged UID to ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code ;; execution via the content-addressed mirror procedures. (That means we @@ -108,10 +114,12 @@ (define (guix-perform-download . args) (((? derivation-path? drv) (? store-path? output)) (assert-low-privileges) (perform-download (read-derivation-from-file drv) - output)) + output + #:print-build-trace? print-build-trace?)) (((? derivation-path? drv)) ;backward compatibility (assert-low-privileges) - (perform-download (read-derivation-from-file drv))) + (perform-download (read-derivation-from-file drv) + #:print-build-trace? print-build-trace?)) (("--version") (show-version-and-exit)) (x diff --git a/nix/libstore/builtins.cc b/nix/libstore/builtins.cc index a5ebb47737..1f52511c80 100644 --- a/nix/libstore/builtins.cc +++ b/nix/libstore/builtins.cc @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2016, 2017 Ludovic Courtès + Copyright (C) 2016, 2017, 2018 Ludovic Courtès This file is part of GNU Guix. @@ -47,6 +47,9 @@ static void builtinDownload(const Derivation &drv, content-addressed mirrors) works correctly. */ setenv("NIX_STORE", settings.nixStore.c_str(), 1); + /* Tell it about options such as "print-extended-build-trace". */ + setenv("_NIX_OPTIONS", settings.pack().c_str(), 1); + /* XXX: Hack our way to use the 'download' script from 'LIBEXECDIR/guix' or just 'LIBEXECDIR', depending on whether we're running uninstalled or not. */ -- cgit v1.2.3 From bb6419f3745911aec87ad79c55bb953b36f246dd Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Thu, 30 Aug 2018 22:08:59 -0400 Subject: build-system: haskell: Add #:cabal-revision argument. Add a #:cabal-revision argument for specifying which Cabal file revision from Hackage should be used. * guix/build-system/haskell.scm (source-url->revision-url): New function. (lower): Accept a cabal-revision keyword argument, convert it to an origin record, and add it to the resulting bag's host-inputs. (haskell-build): Pass the cabal-revision input to the builder as an argument. * guix/build/haskell-build-system.scm (patch-cabal-file): New phase. (%standard-phases): Add it. --- guix/build-system/haskell.scm | 32 +++++++++++++++++++++++++++++++- guix/build/haskell-build-system.scm | 12 ++++++++++++ 2 files changed, 43 insertions(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 1cb734631c..1ec11c71d8 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -21,6 +21,7 @@ (define-module (guix build-system haskell) #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix download) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -48,14 +49,35 @@ (define (default-haskell) (let ((haskell (resolve-interface '(gnu packages haskell)))) (module-ref haskell 'ghc))) +(define (source-url->revision-url url revision) + "Convert URL (a Hackage source URL) to the URL for the Cabal file at +version REVISION." + (let* ((last-slash (string-rindex url #\/)) + (next-slash (string-rindex url #\/ 0 last-slash))) + (string-append (substring url 0 next-slash) + (substring url last-slash (- (string-length url) + (string-length ".tar.gz"))) + "/revision/" revision ".cabal"))) + (define* (lower name #:key source inputs native-inputs outputs system target (haskell (default-haskell)) + cabal-revision #:allow-other-keys #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:target #:haskell #:inputs #:native-inputs)) + '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs)) + + (define (cabal-revision->origin cabal-revision) + (match cabal-revision + ((revision hash) + (origin + (method url-fetch) + (uri (source-url->revision-url (origin-uri source) revision)) + (sha256 (base32 hash)) + (file-name (string-append name "-" revision ".cabal")))) + (#f #f))) (and (not target) ;XXX: no cross-compilation (bag @@ -64,6 +86,9 @@ (define private-keywords (host-inputs `(,@(if source `(("source" ,source)) '()) + ,@(match (cabal-revision->origin cabal-revision) + (#f '()) + (revision `(("cabal-revision" ,revision)))) ,@inputs ;; Keep the standard inputs of 'gnu-build-system'. @@ -103,6 +128,11 @@ (define builder source) (source source)) + #:cabal-revision ,(match (assoc-ref inputs + "cabal-revision") + (((? derivation? revision)) + (derivation->output-path revision)) + (revision revision)) #:configure-flags ,configure-flags #:haddock-flags ,haddock-flags #:system ,system diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 26519ce5a6..be4f5b583b 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -27,6 +27,7 @@ (define-module (guix build haskell-build-system) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 ftw) #:export (%standard-phases haskell-build)) @@ -265,8 +266,19 @@ (define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys) (run-setuphs "haddock" haddock-flags) #t)) +(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys) + (when cabal-revision + ;; Cabal requires there to be a single file with the suffix ".cabal". + (match (scandir "." (cut string-suffix? ".cabal" <>)) + ((original) + (format #t "replacing ~s with ~s~%" original cabal-revision) + (copy-file cabal-revision original)) + (_ (error "Could not find a Cabal file to patch.")))) + #t) + (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'patch-cabal-file patch-cabal-file) (delete 'bootstrap) (add-before 'configure 'setup-compiler setup-compiler) (add-before 'install 'haddock haddock) -- cgit v1.2.3 From a7b751965f8420c871ae24aee25f1eb7a217e608 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Tue, 2 Oct 2018 04:57:31 -0400 Subject: build-system/asdf: Properly handle dependency specification casing. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/lisp-utils.scm (normalize-dependency): Modify match clauses to match the upper-case symbols that lisp produces. Signed-off-by: Ludovic Courtès --- guix/build/lisp-utils.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 6470cfec97..97bc6197a3 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -84,11 +84,12 @@ (define (normalize-string str) (define (normalize-dependency dependency) "Normalize the name of DEPENDENCY. Handles dependency definitions of the dependency-def form described by -." +. +Assume that any symbols in DEPENDENCY will be in upper-case." (match dependency - ((':version name rest ...) + ((':VERSION name rest ...) `(:version ,(normalize-string name) ,@rest)) - ((':feature feature-specification dependency-specification) + ((':FEATURE feature-specification dependency-specification) `(:feature ,feature-specification ,(normalize-dependency dependency-specification))) -- cgit v1.2.3 From 58352f269e46942c34d7ee4e29f91144576ca661 Mon Sep 17 00:00:00 2001 From: Alex Vong Date: Thu, 18 Oct 2018 02:53:32 +0800 Subject: build-system/haskell: Use 'strip-store-file-name'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit See the discussion at . * guix/build/haskell-build-system.scm (package-name-version): Remove it. (configure): Use 'strip-store-file-name' instead of 'package-name-version'. (setup-compiler): Likewise. (make-ghc-package-database): Likewise. (register): Likewise. * gnu/packages/haskell.scm (ghc-cairo)[arguments]: Likewise. * gnu/packages/agda.scm (agda)[arguments]: Likewise. Signed-off-by: Ludovic Courtès --- gnu/packages/agda.scm | 5 +++-- gnu/packages/haskell.scm | 4 ++-- guix/build/haskell-build-system.scm | 20 +++++++++----------- 3 files changed, 14 insertions(+), 15 deletions(-) (limited to 'guix/build') diff --git a/gnu/packages/agda.scm b/gnu/packages/agda.scm index 6bb38aac4d..d2113555eb 100644 --- a/gnu/packages/agda.scm +++ b/gnu/packages/agda.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Alex ter Weele ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2018 Alex Vong ;;; ;;; This file is part of GNU Guix. ;;; @@ -85,6 +86,7 @@ (define-public agda (lambda* (#:key outputs inputs tests? (configure-flags '()) #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) + (name-version (strip-store-file-name out)) (input-dirs (match inputs (((_ . dir) ...) dir) @@ -95,8 +97,7 @@ (define-public agda `(,(string-append "--bindir=" out "/bin")) `(,(string-append "--docdir=" out - "/share/doc/" ((@@ (guix build haskell-build-system) - package-name-version) out))) + "/share/doc/" name-version)) '("--libsubdir=$compiler/$pkg-$version") '("--package-db=../package.conf.d") '("--global") diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm index 0a90ac523c..57435dca07 100644 --- a/gnu/packages/haskell.scm +++ b/gnu/packages/haskell.scm @@ -10619,6 +10619,7 @@ (define-public ghc-cairo (lambda* (#:key outputs inputs tests? (configure-flags '()) #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) + (name-version (strip-store-file-name out)) (input-dirs (match inputs (((_ . dir) ...) dir) @@ -10629,8 +10630,7 @@ (define-public ghc-cairo `(,(string-append "--bindir=" out "/bin")) `(,(string-append "--docdir=" out - "/share/doc/" ((@@ (guix build haskell-build-system) - package-name-version) out))) + "/share/doc/" name-version)) '("--libsubdir=$compiler/$pkg-$version") '("--package-db=../package.conf.d") '("--global") diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 72714a29ad..7b556f6431 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2015 Paul van der Walt ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2018 Alex Vong ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,6 +79,7 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) (doc (assoc-ref outputs "doc")) (lib (assoc-ref outputs "lib")) (bin (assoc-ref outputs "bin")) + (name-version (strip-store-file-name out)) (input-dirs (match inputs (((_ . dir) ...) dir) @@ -88,7 +90,7 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) `(,(string-append "--bindir=" (or bin out) "/bin")) `(,(string-append "--docdir=" (or doc out) - "/share/doc/" (package-name-version out))) + "/share/doc/" name-version)) '("--libsubdir=$compiler/$pkg-$version") `(,(string-append "--package-db=" %tmp-db-dir)) '("--global") @@ -127,12 +129,6 @@ (define* (install #:rest empty) "Install a given Haskell package." (run-setuphs "copy" '())) -(define (package-name-version store-dir) - "Given a store directory STORE-DIR return 'name-version' of the package." - (let* ((base (basename store-dir))) - (string-drop base - (+ 1 (string-index base #\-))))) - (define (grep rx port) "Given a regular-expression RX including a group, read from PORT until the first match and return the content of the group." @@ -147,7 +143,7 @@ (define (grep rx port) (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." (let* ((haskell (assoc-ref inputs "haskell")) - (name-version (package-name-version haskell))) + (name-version (strip-store-file-name haskell))) (cond ((string-match "ghc" name-version) (make-ghc-package-database system inputs outputs)) @@ -164,6 +160,7 @@ (define-syntax-rule (with-null-error-port exp) (define (make-ghc-package-database system inputs outputs) "Generate the GHC package database." (let* ((haskell (assoc-ref inputs "haskell")) + (name-version (strip-store-file-name haskell)) (input-dirs (match inputs (((_ . dir) ...) dir) @@ -171,7 +168,7 @@ (define (make-ghc-package-database system inputs outputs) ;; Silence 'find-files' (see 'evaluate-search-paths') (conf-dirs (with-null-error-port (search-path-as-list - `(,(string-append "lib/" (package-name-version haskell))) + `(,(string-append "lib/" name-version)) input-dirs #:pattern ".*\\.conf.d$"))) (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs))) (mkdir-p %tmp-db-dir) @@ -231,9 +228,10 @@ (define (install-transitive-deps conf-file src dest) (let* ((out (assoc-ref outputs "out")) (haskell (assoc-ref inputs "haskell")) + (name-verion (strip-store-file-name haskell)) (lib (string-append out "/lib")) - (config-dir (string-append lib "/" - (package-name-version haskell) + (config-dir (string-append lib + "/" name-verion "/" name ".conf.d")) (id-rx (make-regexp "^id: *(.*)$")) (config-file (string-append out "/" name ".conf")) -- cgit v1.2.3 From 418f1b241486ef7f98fdce1e6f8e53f2e7863fd9 Mon Sep 17 00:00:00 2001 From: Alex Vong Date: Thu, 18 Oct 2018 03:08:31 +0800 Subject: java-utils: Use 'strip-store-file-name'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit See the discussion at . * guix/build/java-utils.scm (package-name-version): Remove it. (install-javadoc): Use 'strip-store-file-name' instead of 'package-name-version'. Signed-off-by: Ludovic Courtès --- guix/build/java-utils.scm | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) (limited to 'guix/build') diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm index 128be1edeb..8200638bee 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2016 Ricardo Wurmus +;;; Copyright © 2018 Alex Vong ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,12 +24,6 @@ (define-module (guix build java-utils) install-jars install-javadoc)) -;; Copied from haskell-build-system.scm -(define (package-name-version store-dir) - "Given a store directory STORE-DIR return 'name-version' of the package." - (let* ((base (basename store-dir))) - (string-drop base (+ 1 (string-index base #\-))))) - (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) #:allow-other-keys) (apply invoke `("ant" ,target ,@make-flags))) @@ -48,8 +43,9 @@ (define* (install-javadoc apidoc-directory) install javadocs when this is not done by the install target." (lambda* (#:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) + (name-version (strip-store-file-name out)) (docs (string-append (or (assoc-ref outputs "doc") out) - "/share/doc/" (package-name-version out) "/"))) + "/share/doc/" name-version "/"))) (mkdir-p docs) (copy-recursively apidoc-directory docs) #t))) -- cgit v1.2.3