From 3d20ebd6cb09c328c06ea197489aa84802bed5a8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 29 Aug 2015 23:33:53 +0200 Subject: refresh: Add missing newline in warning message. Reported by karhunkynsi on #guix. * guix/scripts/refresh.scm (update-package): Add missing newline in string literal passed to 'warning'. --- guix/scripts/refresh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 28519d78e2..e7980a97b0 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -149,7 +149,7 @@ (define* (update-package store package #:key (key-download 'interactive)) port-sha256))) (update-package-source package version hash))) (warning (_ "~a: version ~a could not be \ -downloaded and authenticated; not updating") +downloaded and authenticated; not updating~%") (package-name package) version))))) -- cgit v1.2.3 From 532164194a96bb3a0e957bf2fe5e7487cf53488d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 29 Aug 2015 23:47:53 +0200 Subject: download: Keep a single copy of the mirror file. This saves ~10% on 'guix build inkscape -Sd'. * guix/download.scm (%mirror-file): New variable. (url-fetch): Remove #:mirrors parameter. Remove 'mirror-file'; refer to '%mirror-file' instead. --- guix/download.scm | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 6e91607196..079d1b0b8d 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -202,6 +202,12 @@ (define %mirrors "http://ftp.fr.debian.org/debian/" "http://ftp.debian.org/debian/")))) +(define %mirror-file + ;; Copy of the list of mirrors to a file. This allows us to keep a single + ;; copy in the store, and computing it here avoids repeated calls to + ;; 'object->string'. + (plain-file "mirrors" (object->string %mirrors))) + (define (gnutls-package) "Return the default GnuTLS package." (let ((module (resolve-interface '(gnu packages tls)))) @@ -210,16 +216,14 @@ (define (gnutls-package) (define* (url-fetch url hash-algo hash #:optional name #:key (system (%current-system)) - (guile (default-guile)) - (mirrors %mirrors)) + (guile (default-guile))) "Return a fixed-output derivation that fetches URL (a string, or a list of strings denoting alternate URLs), which is expected to have hash HASH of type HASH-ALGO (a symbol). By default, the file name is the base name of URL; optionally, NAME can specify a different file name. When one of the URL starts with mirror://, then its host part is -interpreted as the name of a mirror scheme, taken from MIRRORS; MIRRORS -must be a list of symbol/URL-list pairs. +interpreted as the name of a mirror scheme, taken from %MIRROR-FILE. Alternately, when URL starts with file://, return the corresponding file name in the store." @@ -239,10 +243,6 @@ (define need-gnutls? ((url ...) (any https? url))))) - (define mirror-file - ;; Copy the list of mirrors to a file to keep a single copy in the store. - (plain-file "mirrors" (object->string mirrors))) - (define builder #~(begin #+(if need-gnutls? @@ -261,7 +261,7 @@ (define builder (url-fetch (call-with-input-string (getenv "guix download url") read) #$output - #:mirrors (call-with-input-file #$mirror-file read)))) + #:mirrors (call-with-input-file #$%mirror-file read)))) (let ((uri (and (string? url) (string->uri url)))) (if (or (and (string? url) (not uri)) -- cgit v1.2.3 From 521a11e0a68b54bbacbb4912d622a29cfc86c153 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Wed, 12 Aug 2015 14:17:44 +0300 Subject: guix lint: Export checkers and accessors. * guix/scripts/lint.scm (%checkers, lint-checker, lint-checker?, lint-checker-name, lint-checker-description, lint-checker-check): Export. --- guix/scripts/lint.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 14ac8cba81..41249b2d15 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -56,7 +56,14 @@ (define-module (guix scripts lint) check-derivation check-home-page check-source - check-formatting)) + check-formatting + + %checkers + lint-checker + lint-checker? + lint-checker-name + lint-checker-description + lint-checker-check)) ;;; -- cgit v1.2.3 From c1a8c5ab1caf53dad66ff25cb9eeaa1b6b8ed3f3 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Thu, 27 Aug 2015 22:32:23 +0300 Subject: guix graph: Export node types and accessors. * guix/scripts/graph.scm (%node-types, node-type, node-type?, node-type-identifier, node-type-label, node-type-edges, node-type-convert, node-type-name, node-type-description): Export. --- guix/scripts/graph.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'guix') diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 475f054571..1719ffce68 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -39,6 +39,16 @@ (define-module (guix scripts graph) %bag-emerged-node-type %derivation-node-type %reference-node-type + %node-types + + node-type + node-type? + node-type-identifier + node-type-label + node-type-edges + node-type-convert + node-type-name + node-type-description %graphviz-backend graph-backend? -- cgit v1.2.3 From caa6732e967ef4e397533d1cff9ba5626b2b4131 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Sun, 16 Aug 2015 10:28:04 +0300 Subject: ui: Add 'run-guix'. * guix/ui.scm (guix-main): Move the code to run guix command line to ... (run-guix): ...here. New procedure. Export it. --- guix/ui.scm | 51 +++++++++++++++++++++++++++++---------------------- 1 file changed, 29 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index a6d4fd10cf..8de8e3c863 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov -;;; Copyright © 2014 Alex Kost +;;; Copyright © 2014, 2015 Alex Kost ;;; Copyright © 2014 Deck Pickard ;;; ;;; This file is part of GNU Guix. @@ -77,6 +77,7 @@ (define-module (guix ui) args-fold* parse-command-line run-guix-command + run-guix program-name guix-warning-port warning @@ -1032,31 +1033,37 @@ (define module (parameterize ((program-name command)) (apply command-main args)))) +(define (run-guix . args) + "Run the 'guix' command defined by command line ARGS. +Unlike 'guix-main', this procedure assumes that locale, i18n support, +and signal handling has already been set up." + (define option? (cut string-prefix? "-" <>)) + + (match args + (() + (format (current-error-port) + (_ "guix: missing command name~%")) + (show-guix-usage)) + ((or ("-h") ("--help")) + (show-guix-help)) + (("--version") + (show-version-and-exit "guix")) + (((? option? o) args ...) + (format (current-error-port) + (_ "guix: unrecognized option '~a'~%") o) + (show-guix-usage)) + (("help" args ...) + (show-guix-help)) + ((command args ...) + (apply run-guix-command + (string->symbol command) + args)))) + (define guix-warning-port (make-parameter (current-warning-port))) (define (guix-main arg0 . args) (initialize-guix) - (let () - (define (option? str) (string-prefix? "-" str)) - (match args - (() - (format (current-error-port) - (_ "guix: missing command name~%")) - (show-guix-usage)) - ((or ("-h") ("--help")) - (show-guix-help)) - (("--version") - (show-version-and-exit "guix")) - (((? option? o) args ...) - (format (current-error-port) - (_ "guix: unrecognized option '~a'~%") o) - (show-guix-usage)) - (("help" args ...) - (show-guix-help)) - ((command args ...) - (apply run-guix-command - (string->symbol command) - args))))) + (apply run-guix args)) ;;; ui.scm ends here -- cgit v1.2.3 From e1248602f92c45a731e47e74d3612bee03eaa0da Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 24 Jul 2015 16:49:57 +0200 Subject: import: Add 'cran' importer. * guix/import/cran.scm: New file. * guix/scripts/import.scm: Add "cran" to 'importers'. * guix/scripts/import/cran.scm: New file. * tests/cran.scm: New file. * Makefile.am (MODULES): Add 'guix/import/cran.scm' and 'guix/scripts/import/cran.scm'. (SCM_TESTS): Add 'tests/cran.scm'. * doc/guix.texi (Invoking guix import): Document it. * po/guix/POTFILES.in: Add 'guix/scripts/import/cran.scm'. --- Makefile.am | 3 + doc/guix.texi | 15 ++++ guix/import/cran.scm | 188 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 2 +- guix/scripts/import/cran.scm | 92 +++++++++++++++++++++ tests/cran.scm | 178 ++++++++++++++++++++++++++++++++++++++++ 6 files changed, 477 insertions(+), 1 deletion(-) create mode 100644 guix/import/cran.scm create mode 100644 guix/scripts/import/cran.scm create mode 100644 tests/cran.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 85cc7bd50f..af41ea57c8 100644 --- a/Makefile.am +++ b/Makefile.am @@ -97,6 +97,7 @@ MODULES = \ guix/import/gnu.scm \ guix/import/snix.scm \ guix/import/cabal.scm \ + guix/import/cran.scm \ guix/import/hackage.scm \ guix/import/elpa.scm \ guix/scripts/download.scm \ @@ -112,6 +113,7 @@ MODULES = \ guix/scripts/refresh.scm \ guix/scripts/system.scm \ guix/scripts/lint.scm \ + guix/scripts/import/cran.scm \ guix/scripts/import/gnu.scm \ guix/scripts/import/nix.scm \ guix/scripts/import/hackage.scm \ @@ -198,6 +200,7 @@ SCM_TESTS = \ tests/packages.scm \ tests/snix.scm \ tests/hackage.scm \ + tests/cran.scm \ tests/elpa.scm \ tests/store.scm \ tests/monads.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 89291273c4..4dbedb15ec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3939,6 +3939,21 @@ Perl module: guix import cpan Acme::Boolean @end example +@item cran +@cindex CRAN +Import meta-data from @uref{http://cran.r-project.org/, CRAN}, the +central repository for the @uref{http://r-project.org, GNU@tie{}R +statistical and graphical environment}. + +Information is extracted from the HTML package description. + +The command command below imports meta-data for the @code{Cairo} +R package: + +@example +guix import cran Cairo +@end example + @item nix Import meta-data from a local copy of the source of the @uref{http://nixos.org/nixpkgs/, Nixpkgs distribution}@footnote{This diff --git a/guix/import/cran.scm b/guix/import/cran.scm new file mode 100644 index 0000000000..8ed5e5407f --- /dev/null +++ b/guix/import/cran.scm @@ -0,0 +1,188 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus +;;; +;;; 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 import cran) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (sxml simple) + #:use-module (sxml match) + #:use-module (sxml xpath) + #:use-module (guix http-client) + #:use-module (guix hash) + #:use-module (guix store) + #:use-module (guix base32) + #:use-module ((guix download) #:select (download-to-store)) + #:use-module (guix import utils) + #:export (cran->guix-package)) + +;;; Commentary: +;;; +;;; Generate a package declaration template for the latest version of an R +;;; package on CRAN, using the HTML description downloaded from +;;; cran.r-project.org. +;;; +;;; Code: + +(define string->license + (match-lambda + ("AGPL-3" 'agpl3+) + ("Artistic-2.0" 'artistic2.0) + ("Apache License 2.0" 'asl2.0) + ("BSD_2_clause" 'bsd-2) + ("BSD_3_clause" 'bsd-3) + ("GPL-2" 'gpl2+) + ("GPL-3" 'gpl3+) + ("LGPL-2" 'lgpl2.0+) + ("LGPL-2.1" 'lgpl2.1+) + ("LGPL-3" 'lgpl3+) + ("MIT" 'x11) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + +(define (format-inputs names) + "Generate a sorted list of package inputs from a list of package NAMES." + (map (lambda (name) + (list name (list 'unquote (string->symbol name)))) + (sort names string-cisxml (http-fetch cran-url) + #:trim-whitespace? #t + #:namespaces '((xhtml . "http://www.w3.org/1999/xhtml")) + #:default-entity-handler + (lambda (port name) + (case name + ((nbsp) " ") + ((ge) ">=") + ((gt) ">") + ((lt) "<") + (else + (format (current-warning-port) + "~a:~a:~a: undefined entitity: ~a\n" + cran-url (port-line port) (port-column port) + name) + (symbol->string name)))))))) + +(define (cran-sxml->sexp sxml) + "Return the `package' s-expression for a CRAN package from the SXML +representation of the package page." + (define (nodes->text nodeset) + (string-join ((sxpath '(// *text*)) nodeset) " ")) + + (define (guix-name name) + (if (string-prefix? "r-" name) + (string-downcase name) + (string-append "r-" (string-downcase name)))) + + (sxml-match-let* + (((*TOP* (xhtml:html + ,head + (xhtml:body + (xhtml:h2 ,name-and-synopsis) + (xhtml:p ,description) + ,summary + (xhtml:h4 "Downloads:") ,downloads + . ,rest))) + sxml)) + (let* ((name (match:prefix (string-match ": " name-and-synopsis))) + (synopsis (match:suffix (string-match ": " name-and-synopsis))) + (version (nodes->text (table-datum summary "Version:"))) + (license ((compose string->license nodes->text) + (table-datum summary "License:"))) + (home-page (nodes->text ((sxpath '((xhtml:a 1))) + (table-datum summary "URL:")))) + (source-url (string-append "mirror://cran/" + ;; Remove double dots, because we want an + ;; absolute path. + (regexp-substitute/global + #f "\\.\\./" + (string-join + ((sxpath '((xhtml:a 1) @ href *text*)) + (table-datum downloads + " Package source: "))) + 'pre 'post))) + (tarball (with-store store (download-to-store store source-url))) + (sysdepends (map match:substring + (list-matches + "[^ ]+" + ;; Strip off comma and parenthetical + ;; expressions. + (regexp-substitute/global + #f "(,|\\([^\\)]+\\))" + (nodes->text (table-datum summary + "SystemRequirements:")) + 'pre 'post)))) + (imports (map guix-name + ((sxpath '(// xhtml:a *text*)) + (table-datum summary "Imports:"))))) + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs imports 'propagated-inputs) + (home-page ,(if (string-null? home-page) + (string-append %cran-url name) + home-page)) + (synopsis ,synopsis) + ;; Use double spacing + (description ,(regexp-substitute/global #f "\\. \\b" description + 'pre ". " 'post)) + (license ,license))))) + +(define (cran->guix-package package-name) + "Fetch the metadata for PACKAGE-NAME from cran.r-project.org, and return the +`package' s-expression corresponding to that package, or #f on failure." + (let ((module-meta (cran-fetch package-name))) + (and=> module-meta cran-sxml->sexp))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 6cd762a537..7b29794e8f 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ (define %standard-import-options '()) ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm new file mode 100644 index 0000000000..f11fa1004f --- /dev/null +++ b/guix/scripts/import/cran.scm @@ -0,0 +1,92 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2015 Ricardo Wurmus +;;; +;;; 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 scripts import cran) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix import cran) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-cran)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import cran PACKAGE-NAME +Import and convert the CRAN package for PACKAGE-NAME.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import cran"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-cran . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (cran->guix-package package-name))) + (unless sexp + (leave (_ "failed to download description for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/tests/cran.scm b/tests/cran.scm new file mode 100644 index 0000000000..c9cb5f69d0 --- /dev/null +++ b/tests/cran.scm @@ -0,0 +1,178 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus +;;; +;;; 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-cran) + #:use-module (guix import cran) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(define sxml + '(*TOP* (xhtml:html + (xhtml:head + (xhtml:title "CRAN - Package my-example-sxml")) + (xhtml:body + (xhtml:h2 "my-example-sxml: Short description") + (xhtml:p "Long description") + (xhtml:table + (@ (summary "Package my-example-sxml summary")) + (xhtml:tr + (xhtml:td "Version:") + (xhtml:td "1.2.3")) + (xhtml:tr + (xhtml:td "Depends:") + (xhtml:td "R (>= 3.1.0)")) + (xhtml:tr + (xhtml:td "SystemRequirements:") + (xhtml:td "cairo (>= 1.2 http://www.cairographics.org/)")) + (xhtml:tr + (xhtml:td "Imports:") + (xhtml:td + (xhtml:a (@ (href "../scales/index.html")) + "scales") + " (>= 0.2.3), " + (xhtml:a (@ (href "../proto/index.html")) + "proto") + ", " + (xhtml:a (@ (href "../Rcpp/index.html")) "Rcpp") + " (>= 0.11.0)")) + (xhtml:tr + (xhtml:td "Suggests:") + (xhtml:td + (xhtml:a (@ (href "../some/index.html")) + "some") + ", " + (xhtml:a (@ (href "../suggestions/index.html")) + "suggestions"))) + (xhtml:tr + (xhtml:td "License:") + (xhtml:td + (xhtml:a (@ (href "../../licenses/MIT")) "MIT"))) + (xhtml:tr + (xhtml:td "URL:") + (xhtml:td + (xhtml:a (@ (href "http://gnu.org/s/my-example-sxml")) + "http://gnu.org/s/my-example-sxml") + ", " + (xhtml:a (@ (href "http://alternative/home/page")) + "http://alternative/home/page")))) + (xhtml:h4 "Downloads:") + (xhtml:table + (@ (summary "Package my-example-sxml downloads")) + (xhtml:tr + (xhtml:td " Reference manual: ") + (xhtml:td + (xhtml:a (@ (href "my-example-sxml.pdf")) + " my-example-sxml.pdf "))) + (xhtml:tr + (xhtml:td " Package source: ") + (xhtml:td + (xhtml:a + (@ (href "../../../src/contrib/my-example-sxml_1.2.3.tar.gz")) + " my-example-sxml_1.2.3.tar.gz ")))) + (xhtml:h4 "Reverse dependencies:") + (xhtml:table + (@ (summary "Package my-example-sxml reverse dependencies")) + (xhtml:tr + (xhtml:td "Reverse depends:") + (xhtml:td "Too many.")) + (xhtml:tr + (xhtml:td "Reverse imports:") + (xhtml:td "Likewise.")) + (xhtml:tr + (xhtml:td "Reverse suggests:") + (xhtml:td "Uncountable."))))))) + +(define simple-table + '(xhtml:table + (xhtml:tr + (xhtml:td "Numbers") + (xhtml:td "123")) + (xhtml:tr + (@ (class "whatever")) + (xhtml:td (@ (class "unimportant")) "Letters") + (xhtml:td "abc")) + (xhtml:tr + (xhtml:td "Letters") + (xhtml:td "xyz")) + (xhtml:tr + (xhtml:td "Single")) + (xhtml:tr + (xhtml:td "not a value") + (xhtml:td "not a label") + (xhtml:td "also not a label")))) + +(test-begin "cran") + +(test-equal "table-datum: return list of first table cell matching label" + '((xhtml:td "abc")) + ((@@ (guix import cran) table-datum) simple-table "Letters")) + +(test-equal "table-datum: return empty list if no match" + '() + ((@@ (guix import cran) table-datum) simple-table "Astronauts")) + +(test-equal "table-datum: only consider the first cell as a label cell" + '() + ((@@ (guix import cran) table-datum) simple-table "not a label")) + + +(test-assert "cran-sxml->sexp" + ;; Replace network resources with sample data. + (mock ((guix build download) url-fetch + (lambda* (url file-name #:key (mirrors '())) + (with-output-to-file file-name + (lambda () + (display + (match url + ("mirror://cran/src/contrib/my-example-sxml_1.2.3.tar.gz" + "source") + (_ (error "Unexpected URL: " url)))))))) + (match ((@@ (guix import cran) cran-sxml->sexp) sxml) + (('package + ('name "r-my-example-sxml") + ('version "1.2.3") + ('source ('origin + ('method 'url-fetch) + ('uri ('string-append "mirror://cran/src/contrib/my-example-sxml_" + 'version ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'r-build-system) + ('inputs + ('quasiquote + (("cairo" ('unquote 'cairo))))) + ('propagated-inputs + ('quasiquote + (("r-proto" ('unquote 'r-proto)) + ("r-rcpp" ('unquote 'r-rcpp)) + ("r-scales" ('unquote 'r-scales))))) + ('home-page "http://gnu.org/s/my-example-sxml") + ('synopsis "Short description") + ('description "Long description") + ('license 'x11))) + (x + (begin + (format #t "~s\n" x) + (pk 'fail x #f)))))) + +(test-end "cran") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From f8f3bef6aac4ed96bfd236567536c4b039b7bd31 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 31 Jul 2015 14:47:34 +0200 Subject: build: Add R build system. * guix/build-system/r.scm: New file. * guix/build/r-build-system: New file. * Makefile.am (MODULES): Add new files. * doc/guix.texi (Build Systems): Document r-build-system. --- Makefile.am | 2 + doc/guix.texi | 10 ++++ guix/build-system/r.scm | 134 ++++++++++++++++++++++++++++++++++++++++++ guix/build/r-build-system.scm | 112 +++++++++++++++++++++++++++++++++++ 4 files changed, 258 insertions(+) create mode 100644 guix/build-system/r.scm create mode 100644 guix/build/r-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index af41ea57c8..711181b7cf 100644 --- a/Makefile.am +++ b/Makefile.am @@ -58,6 +58,7 @@ MODULES = \ guix/build-system/perl.scm \ guix/build-system/python.scm \ guix/build-system/waf.scm \ + guix/build-system/r.scm \ guix/build-system/ruby.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ @@ -77,6 +78,7 @@ MODULES = \ guix/build/gnu-dist.scm \ guix/build/perl-build-system.scm \ guix/build/python-build-system.scm \ + guix/build/r-build-system.scm \ guix/build/ruby-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 4dbedb15ec..c42aedbbb0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2491,6 +2491,16 @@ passes flags specified by the @code{#:make-maker-flags} or Which Perl package is used can be specified with @code{#:perl}. @end defvr +@defvr {Scheme Variable} r-build-system +This variable is exported by @code{(guix build-system r)}. It +implements the build procedure used by @uref{http://r-project.org, R} +packages, which essentially is little more than running @code{R CMD +INSTALL --library=/gnu/store/@dots{}} in an environment where +@code{R_LIBS_SITE} contains the paths to all R package inputs. Tests +are run after installation using the R function +@code{tools::testInstalledPackage}. +@end defvr + @defvr {Scheme Variable} ruby-build-system This variable is exported by @code{(guix build-system ruby)}. It implements the RubyGems build procedure used by Ruby packages, which diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm new file mode 100644 index 0000000000..4daec5eb66 --- /dev/null +++ b/guix/build-system/r.scm @@ -0,0 +1,134 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus +;;; +;;; 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 build-system r) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (%r-build-system-modules + r-build + r-build-system)) + +;; Commentary: +;; +;; Standard build procedure for R packages. +;; +;; Code: + +(define %r-build-system-modules + ;; Build-side modules imported by default. + `((guix build r-build-system) + ,@%gnu-build-system-modules)) + +(define (default-r) + "Return the default R package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((r-mod (resolve-interface '(gnu packages statistics)))) + (module-ref r-mod 'r))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (r (default-r)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("r" ,r) + ,@native-inputs)) + (outputs outputs) + (build r-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (r-build store name inputs + #:key + (tests? #t) + (test-target "tests") + (configure-flags ''()) + (phases '(@ (guix build r-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %r-build-system-modules) + (modules '((guix build r-build-system) + (guix build utils)))) + "Build SOURCE with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (r-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:configure-flags ,configure-flags + #:system ,system + #:tests? ,tests? + #:test-target ,test-target + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define r-build-system + (build-system + (name 'r) + (description "The standard R build system") + (lower lower))) + +;;; r.scm ends here diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm new file mode 100644 index 0000000000..3fc13eb835 --- /dev/null +++ b/guix/build/r-build-system.scm @@ -0,0 +1,112 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ricardo Wurmus +;;; +;;; 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 build r-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 popen) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + r-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for R packages. +;; +;; Code: + +(define (invoke-r command params) + (zero? (apply system* "R" "CMD" command params))) + +(define (pipe-to-r command params) + (let ((port (apply open-pipe* OPEN_WRITE "R" params))) + (display command port) + (zero? (status:exit-val (close-pipe port))))) + +(define (generate-site-path inputs) + (string-join (map (match-lambda + ((_ . path) + (string-append path "/site-library"))) + ;; Restrict to inputs beginning with "r-". + (filter (match-lambda + ((name . _) + (string-prefix? "r-" name))) + inputs)) + ":")) + +(define* (check #:key test-target inputs outputs tests? #:allow-other-keys) + "Run the test suite of a given R package." + (let* ((libdir (string-append (assoc-ref outputs "out") "/site-library/")) + + ;; R package names are case-sensitive and cannot be derived from the + ;; Guix package name. The exact package name is required as an + ;; argument to ‘tools::testInstalledPackage’, which runs the tests + ;; for a package given its name and the path to the “library” (a + ;; location for a collection of R packages) containing it. + + ;; Since there can only be one R package in any collection (= + ;; “library”), the name of the only directory in the collection path + ;; is the original name of the R package. + (pkg-name (car (scandir libdir (negate (cut member <> '("." "..")))))) + (testdir (string-append libdir pkg-name "/" test-target)) + (site-path (string-append libdir ":" (generate-site-path inputs)))) + (if (and tests? (file-exists? testdir)) + (begin + (setenv "R_LIBS_SITE" site-path) + (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\")") + '("--no-save" "--slave"))) + #t))) + +(define* (install #:key outputs inputs (configure-flags '()) + #:allow-other-keys) + "Install a given R package." + (let* ((out (assoc-ref outputs "out")) + (site-library (string-append out "/site-library/")) + (params (append configure-flags + (list "--install-tests" + (string-append "--library=" site-library) + "."))) + (site-path (string-append site-library ":" + (generate-site-path inputs)))) + ;; If dependencies cannot be found at install time, R will refuse to + ;; install the package. + (setenv "R_LIBS_SITE" site-path) + ;; Some R packages contain a configure script for which the CONFIG_SHELL + ;; variable should be set. + (setenv "CONFIG_SHELL" (which "bash")) + (mkdir-p site-library) + (invoke-r "INSTALL" params))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (delete 'build) + (delete 'check) ; tests must be run after installation + (replace 'install install) + (add-after 'install 'check check))) + +(define* (r-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given R package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; r-build-system.scm ends here -- cgit v1.2.3 From a96524cc7d302ad6a8f2cd2e970a148b360f629a Mon Sep 17 00:00:00 2001 From: David Thompson Date: Tue, 1 Sep 2015 19:57:44 -0400 Subject: import: gem: Fix minor bug and add unit test. * guix/import/gem.scm (make-gem-sexp): Properly handle an empty list of licenses. When rendering a list of licenses, cons 'list onto the front of the expression. * tests/gem.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 3 +- guix/import/gem.scm | 3 +- tests/gem.scm | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 86 insertions(+), 2 deletions(-) create mode 100644 tests/gem.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 711181b7cf..9a810e4ebd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -231,7 +231,8 @@ MODULES += \ SCM_TESTS += \ tests/pypi.scm \ - tests/cpan.scm + tests/cpan.scm \ + tests/gem.scm endif diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 3c28d1d9fd..c64c4e9374 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -105,8 +105,9 @@ (define (make-gem-sexp name version hash home-page description (description ,description) (home-page ,home-page) (license ,(match licenses + (() #f) ((license) (license->symbol license)) - (_ (map license->symbol licenses)))))) + (_ `(list ,@(map license->symbol licenses))))))) (define* (gem->guix-package package-name #:optional version) "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the diff --git a/tests/gem.scm b/tests/gem.scm new file mode 100644 index 0000000000..9efbda31fe --- /dev/null +++ b/tests/gem.scm @@ -0,0 +1,82 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson +;;; +;;; 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-gem) + #:use-module (guix import gem) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix tests) + #:use-module ((guix build utils) #:select (delete-file-recursively)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(define test-json + "{ + \"name\": \"foo\", + \"version\": \"1.0.0\", + \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\", + \"info\": \"A cool gem\", + \"homepage_uri\": \"https://example.com\", + \"dependencies\": { + \"runtime\": [ + { \"name\": \"bundler\" }, + { \"name\": \"bar\" } + ] + }, + \"licenses\": [\"MIT\", \"Apache 2.0\"] +}") + +(test-begin "gem") + +(test-assert "gem->guix-package" + ;; Replace network resources with sample data. + (mock ((guix import utils) url-fetch + (lambda (url file-name) + (match url + ("https://rubygems.org/api/v1/gems/foo.json" + (with-output-to-file file-name + (lambda () + (display test-json)))) + (_ (error "Unexpected URL: " url))))) + (match (gem->guix-package "foo") + (('package + ('name "ruby-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri ('rubygems-uri "foo" 'version)) + ('sha256 + ('base32 + "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk")))) + ('build-system 'ruby-build-system) + ('propagated-inputs + ('quasiquote + (("bundler" ('unquote 'bundler)) + ("ruby-bar" ('unquote 'ruby-bar))))) + ('synopsis "A cool gem") + ('description "A cool gem") + ('home-page "https://example.com") + ('license ('list 'expat 'asl2.0))) + #t) + (x + (pk 'fail x #f))))) + +(test-end "gem") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From dee38b7b41a7415ac3e43757635f0964508db250 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 30 Aug 2015 19:40:17 +0200 Subject: guix: Add GUST font license 1.0. * guix/licenses.scm (gfl1.0): New variable. --- guix/licenses.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index dae0e3d386..024f0c294c 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013, 2015 Andreas Enge ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2015 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,6 +39,7 @@ (define-module (guix licenses) expat freetype gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ + gfl1.0 fdl1.3+ opl1.0+ isc @@ -211,6 +213,13 @@ (define gpl3+ "https://www.gnu.org/licenses/gpl.html" "https://www.gnu.org/licenses/license-list#GNUGPLv3")) +;; The “GUST font license” is legally equivalent to LPPL v1.3c as it only +;; extends the LPPL with an optional request. +(define gfl1.0 + (license "GUST font license 1.0" + "http://www.gust.org.pl/projects/e-foundry/licenses/GUST-FONT-LICENSE.txt" + "https://www.gnu.org/licenses/license-list#LPPL-1.3a")) + (define fdl1.3+ (license "FDL 1.3+" "https://www.gnu.org/licenses/fdl.html" -- cgit v1.2.3 From 4c8f997a7d6f4c9d7eae73804e9784b4562eb213 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Sep 2015 15:23:52 +0200 Subject: graph: Add '--expression'. * guix/scripts/graph.scm (%options, show-help): Add '--expression'. (guix-graph): Call 'read/eval-package-expression' for 'expression' pairs in OPTS. * tests/guix-graph.sh: Add tests. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 10 ++++++++++ guix/scripts/graph.scm | 17 ++++++++++++----- tests/guix-graph.sh | 5 +++++ 3 files changed, 27 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 6defb0bda7..f943540ac8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4417,6 +4417,16 @@ the values listed above. @item --list-types List the supported graph types. + +@item --expression=@var{expr} +@itemx -e @var{expr} +Consider the package @var{expr} evaluates to. + +This is useful to precisely refer to a package, as in this example: + +@example +guix graph -e '(@@@@ (gnu packages commencement) gnu-make-final)' +@end example @end table diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 1719ffce68..2b671be131 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -380,6 +380,9 @@ (define %options (lambda (opt name arg result) (list-node-types) (exit 0))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -397,6 +400,8 @@ (define (show-help) -t, --type=TYPE represent nodes of the given TYPE")) (display (_ " --list-types list the available graph types")) + (display (_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) (newline) (display (_ " -h, --help display this help and exit")) @@ -417,12 +422,14 @@ (define (guix-graph . args) (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options))) - (specs (filter-map (match-lambda - (('argument . spec) spec) - (_ #f)) - opts)) (type (assoc-ref opts 'node-type)) - (packages (map specification->package specs))) + (packages (filter-map (match-lambda + (('argument . spec) + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts))) (with-store store (run-with-store store (mlet %store-monad ((nodes (mapm %store-monad diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh index 199258a9b8..e0cbebb753 100644 --- a/tests/guix-graph.sh +++ b/tests/guix-graph.sh @@ -32,3 +32,8 @@ done guix build guile-bootstrap guix graph -t references guile-bootstrap | grep guile-bootstrap + +guix graph -e '(@ (gnu packages bootstrap) %bootstrap-guile)' \ + | grep guile-bootstrap + +if guix graph -e +; then false; else true; fi -- cgit v1.2.3 From 9d2f48df024fab5b99f1243cdf912a926c0e1e3d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 3 Sep 2015 23:37:33 +0200 Subject: publish: Gracefully handle the lack of a deriver. * guix/scripts/publish.scm (narinfo-string): Catch 'system-error' around 'load-derivation' call; return BASE-INFO upon ENOENT. This allows us to return the narinfo even if DERIVER is missing. Before that, the exception would be uncaught, leading to 500 Internal Error on the client side. --- guix/scripts/publish.scm | 23 ++++++++++++++++------- guix/scripts/substitute.scm | 2 +- 2 files changed, 17 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index e3bcac8047..cc96355947 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -151,7 +151,7 @@ (define (narinfo-string store-path path-info key) (references (string-join (map basename (path-info-references path-info)) " ")) - (deriver (path-info-deriver path-info)) + (deriver (path-info-deriver path-info)) (base-info (format #f "StorePath: ~a URL: ~a @@ -162,12 +162,21 @@ (define (narinfo-string store-path path-info key) store-path url hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. - (info (if (string-null? deriver) - base-info - (let ((drv (load-derivation deriver))) - (format #f "~aSystem: ~a~%Deriver: ~a~%" - base-info (derivation-system drv) - (basename deriver))))) + (info (if (string-null? deriver) + base-info + (catch 'system-error + (lambda () + (let ((drv (load-derivation deriver))) + (format #f "~aSystem: ~a~%Deriver: ~a~%" + base-info (derivation-system drv) + (basename deriver)))) + (lambda args + ;; DERIVER might be missing, but that's fine: + ;; it's only used for where it's + ;; optional. 'System' is currently unused. + (if (= ENOENT (system-error-errno args)) + base-info + (apply throw args)))))) (signature (base64-encode-string (canonical-sexp->string (signed-string info))))) (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 95aae2a372..e908bc997e 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -703,7 +703,7 @@ (define (show-help) ;;; (define (display-narinfo-data narinfo) - "Write to the current output port the contents of NARINFO is the format + "Write to the current output port the contents of NARINFO in the format expected by the daemon." (format #t "~a\n~a\n~a\n" (narinfo-path narinfo) -- cgit v1.2.3 From dbbc248aeef1bc3b5d76268782acff43e9d71d57 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Sep 2015 18:31:06 +0200 Subject: monads: Fix 'liftN' fallback case. Reported by Andy Wingo . * guix/monads.scm (define-lift) : Add missing #'. Remove extra formal parameter. * tests/monads.scm ("lift"): Add test with 'lift1' as a procedure. --- guix/monads.scm | 8 ++++---- tests/monads.scm | 4 +++- 2 files changed, 7 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/monads.scm b/guix/monads.scm index 61cd533bf4..0b0ad239de 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -239,10 +239,10 @@ (define-syntax liftn (identifier? #'id) ;; Slow path: Return a closure-returning procedure (we don't ;; guarantee (eq? LIFTN LIFTN), but that's fine.) - (lambda (liftn proc monad) - (lambda (args ...) - (with-monad monad - (return (proc args ...)))))))))))) + #'(lambda (proc monad) + (lambda (args ...) + (with-monad monad + (return (proc args ...)))))))))))) (define-lift lift0 ()) (define-lift lift1 (a)) diff --git a/tests/monads.scm b/tests/monads.scm index d3ef065f24..62a07a2bc6 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -95,10 +95,12 @@ (define (g x) (test-assert "lift" (every (lambda (monad run) - (let ((f (lift1 1+ monad))) + (let ((f (lift1 1+ monad)) + (g (apply lift1 1+ (list monad)))) (with-monad monad (let ((number (random 777))) (= (run (>>= (return number) f)) + (run (>>= (return number) g)) (1+ number)))))) %monads %monad-run)) -- cgit v1.2.3 From cf897cbacc3ddcf5d5d553ee19002995985fff11 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 5 Sep 2015 13:36:53 -0400 Subject: build: syscalls: Properly handle clone errors. * guix/build/syscalls.scm (clone): Catch -1 return value and throw error. --- guix/build/syscalls.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index fc801a5e9d..093eb0a1a0 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -325,7 +325,13 @@ (define clone "Create a new child process by duplicating the current parent process. Unlike the fork system call, clone accepts FLAGS that specify which resources are shared between the parent and child processes." - (proc syscall-id flags %null-pointer)))) + (let ((ret (proc syscall-id flags %null-pointer)) + (err (errno))) + (if (= ret -1) + (throw 'system-error "clone" "~d: ~A" + (list flags (strerror err)) + (list err)) + ret))))) (define setns ;; Some systems may be using an old (pre-2.14) version of glibc where there -- cgit v1.2.3 From 6b44a09747d18f1570c26f135c7f1a88c317201c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Sep 2015 19:24:16 +0200 Subject: download: Disable offloading for downloads. * guix/download.scm (url-fetch): Use #:local-build? #t. * guix/git-download.scm (git-fetch): Likewise. --- guix/download.scm | 11 +++++------ guix/git-download.scm | 4 +--- 2 files changed, 6 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 079d1b0b8d..42956772f5 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -288,12 +288,11 @@ (define builder ;; Honor the user's proxy settings. #:leaked-env-vars '("http_proxy" "https_proxy") - ;; In general, offloading downloads is not a good idea. - ;;#:local-build? #t - ;; FIXME: The above would also disable use of - ;; substitutes on old daemons, so comment it out; - ;; see . - ))))) + ;; In general, offloading downloads is not a good + ;; idea. Daemons before 0.8.3 would also + ;; interpret this as "do not substitute" (see + ;; .) + #:local-build? #t))))) (define* (download-to-store store url #:optional (name (basename url)) #:key (log (current-error-port)) recursive?) diff --git a/guix/git-download.scm b/guix/git-download.scm index 0f2218c13e..1e5c845e34 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -89,9 +89,7 @@ (define build (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build #:system system - ;; FIXME: See . - ;; Uncomment when fixed daemons are widely deployed. - ;;#:local-build? #t + #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo #:hash hash #:recursive? #t -- cgit v1.2.3 From 6480fcae24db573aa11efaffe4157e2480b5d881 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Thu, 3 Sep 2015 10:35:19 +0300 Subject: emacs-build-system: Fix a file name of info directory. * guix/build/emacs-build-system.scm (move-doc): Adjust to use "/share/info" instead of its sub-directory. --- guix/build/emacs-build-system.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index f18db0aadd..c01b24fe9a 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -83,8 +83,7 @@ (define* (move-doc #:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) (el-dir (string-append out %install-suffix "/" elpa-name-ver)) - (name-ver (store-directory->name-version out)) - (info-dir (string-append out "/share/info/" name-ver)) + (info-dir (string-append out "/share/info")) (info-files (find-files el-dir "\\.info$"))) (unless (null? info-files) (mkdir-p info-dir) -- cgit v1.2.3 From 52b9efe337d00f2ce65c4d4ca74ccc3679e6aad8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Sep 2015 10:54:51 +0200 Subject: lint: Add 'license' checker. * guix/scripts/lint.scm (check-license): New procedure. (%checkers): Add 'license' checker. * tests/lint.scm ("license: invalid license"): New test. --- guix/scripts/lint.scm | 19 +++++++++++++++++++ tests/lint.scm | 6 ++++++ 2 files changed, 25 insertions(+) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 41249b2d15..2a618c9451 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -24,6 +24,7 @@ (define-module (guix scripts lint) #:use-module (guix download) #:use-module (guix ftp-client) #:use-module (guix packages) + #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix ui) #:use-module (guix utils) @@ -56,6 +57,7 @@ (define-module (guix scripts lint) check-derivation check-home-page check-source + check-license check-formatting %checkers @@ -518,6 +520,16 @@ (define (check-derivation package) (format #f (_ "failed to create derivation: ~s~%") args))))) +(define (check-license package) + "Warn about type errors of the 'license' field of PACKAGE." + (match (package-license package) + ((or (? license?) + ((? license?) ...)) + #t) + (x + (emit-warning package (_ "invalid license field") + 'license)))) + ;;; ;;; Source code formatting. @@ -619,6 +631,13 @@ (define %checkers (name 'home-page) (description "Validate home-page URLs") (check check-home-page)) + (lint-checker + (name 'license) + ;; TRANSLATORS: is the name of a data type and must not be + ;; translated. + (description "Make sure the 'license' field is a \ +or a list thereof") + (check check-license)) (lint-checker (name 'source) (description "Validate source URLs") diff --git a/tests/lint.scm b/tests/lint.scm index 5d56420966..ac47dbb768 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -329,6 +329,12 @@ (define-syntax-rule (with-warnings body ...) (check-derivation pkg))) "failed to create derivation"))) +(test-assert "license: invalid license" + (string-contains + (with-warnings + (check-license (dummy-package "x" (license #f)))) + "invalid license")) + (test-assert "home-page: wrong home-page" (->bool (string-contains -- cgit v1.2.3 From 12abc6e39548a55c2b6ba4113f9f1bde8d5d08e1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Sep 2015 12:34:03 +0200 Subject: licenses: Add CC-BY-SA and CC-BY. * guix/licenses.scm (cc-by-sa4.0, cc-by3.0): New variables. --- guix/licenses.scm | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 024f0c294c..c3b76af9b9 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -30,6 +30,7 @@ (define-module (guix licenses) non-copyleft bsd-style ;deprecated! cc0 + cc-by-sa4.0 cc-by3.0 cddl1.0 cecill-c artistic2.0 clarified-artistic @@ -137,6 +138,16 @@ (define cc0 "http://directory.fsf.org/wiki/License:CC0" "http://www.gnu.org/licenses/license-list.html#CC0")) +(define cc-by-sa4.0 + (license "CC-BY-SA 4.0" + "http://creativecommons.org/licenses/by-sa/4.0/" + "Creative Commons Attribution-ShareAlike 4.0 International")) + +(define cc-by3.0 + (license "CC-BY 3.0" + "http://creativecommons.org/licenses/by/3.0/" + "Creative Commons Attribution 3.0 Unported")) + (define cddl1.0 (license "CDDL 1.0" "http://directory.fsf.org/wiki/License:CDDLv1.0" -- cgit v1.2.3 From a5c0d8bc557affbcb58a4d2cb0059604e0cb89fa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Sep 2015 15:47:06 +0200 Subject: ui: Change 'P_' to return the empty string when passed the empty string. Reported by Mathieu Lirzin at . * guix/ui.scm (P_): Check whether MSGID is empty, and return it if it is. --- guix/ui.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 8de8e3c863..2f757547cf 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -99,7 +99,15 @@ (define %package-text-domain (define _ (cut gettext <> %gettext-domain)) (define N_ (cut ngettext <> <> <> %gettext-domain)) -(define P_ (cut gettext <> %package-text-domain)) + +(define (P_ msgid) + "Return the translation of the package description or synopsis MSGID." + ;; Descriptions/synopses might occasionally be empty strings, even if that + ;; is something we try to avoid. Since (gettext "") can return a non-empty + ;; string, explicitly check for that case. + (if (string-null? msgid) + msgid + (gettext msgid %package-text-domain))) (define-syntax-rule (define-diagnostic name prefix) "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all -- cgit v1.2.3 From b500e7182d3278cbbe3ba3cb5c83ba985554aff7 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 29 Aug 2015 21:55:12 -0400 Subject: build: ruby: Avoid long build directory names. Having the hash of the source gem in the source directory file name proved to be problematic when running the test suite for the 'pg' gem that creates UNIX-domain sockets in the source directory and exceeded the 108 character limit on GNU/Linux systems. * guix/build/ruby-build-system.scm (unpack): Rename unpacked gem directory to "gem". --- guix/build/ruby-build-system.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 90fab92f6a..4184ccc9ac 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -44,12 +44,16 @@ (define (first-matching-file pattern) (define* (unpack #:key source #:allow-other-keys) "Unpack the gem SOURCE and enter the resulting directory." (and (zero? (system* "gem" "unpack" source)) - (begin - ;; The unpacked gem directory is named the same as the archive, sans - ;; the ".gem" extension. - (chdir (match:substring (string-match "^(.*)\\.gem$" - (basename source)) - 1)) + ;; The unpacked gem directory is named the same as the archive, sans + ;; the ".gem" extension. It is renamed to simply "gem" in an effort to + ;; keep file names shorter to avoid UNIX-domain socket file names and + ;; shebangs that exceed the system's fixed maximum length when running + ;; test suites. + (let ((dir (match:substring (string-match "^(.*)\\.gem$" + (basename source)) + 1))) + (rename-file dir "gem") + (chdir "gem") #t))) (define* (build #:key source #:allow-other-keys) -- cgit v1.2.3 From ee78d02452208b3cfd971cd5533570a1d3523512 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 5 Sep 2015 14:10:08 -0400 Subject: build: container: Use the same clone flags as fork(3). The intent is to make 'clone' behave a lot more like 'primitive-fork', which calls clone(2) with SIGCHLD, CLONE_CHILD_CLEARTID, and CLONE_CHILD_SETTID flags. Notably, running 'clone' at the REPL without these flags would break the REPL beyond repair. * guix/build/syscalls.scm (CLONE_CHILD_CLEARTID, CLONE_CHILD_SETTID): New variables. * gnu/build/linux-container.scm (namespaces->bit-mask): Add CLONE_CHILD_CLEARTID and CLONE_CHILD_SETTID to bit mask. --- gnu/build/linux-container.scm | 3 ++- guix/build/syscalls.scm | 16 ++++++++++------ 2 files changed, 12 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index c004303f03..95220d0bc0 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -162,7 +162,8 @@ (define (scope file) (define (namespaces->bit-mask namespaces) "Return the number suitable for the 'flags' argument of 'clone' that corresponds to the symbols in NAMESPACES." - (apply logior SIGCHLD + ;; Use the same flags as fork(3) in addition to the namespace flags. + (apply logior SIGCHLD CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID (map (match-lambda ('mnt CLONE_NEWNS) ('uts CLONE_NEWUTS) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 093eb0a1a0..2c2fbde0a3 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -50,6 +50,8 @@ (define-module (guix build syscalls) mkdtemp! pivot-root + CLONE_CHILD_CLEARTID + CLONE_CHILD_SETTID CLONE_NEWNS CLONE_NEWUTS CLONE_NEWIPC @@ -303,12 +305,14 @@ (define mkdtemp! (pointer->string result))))) ;; Linux clone flags, from linux/sched.h -(define CLONE_NEWNS #x00020000) -(define CLONE_NEWUTS #x04000000) -(define CLONE_NEWIPC #x08000000) -(define CLONE_NEWUSER #x10000000) -(define CLONE_NEWPID #x20000000) -(define CLONE_NEWNET #x40000000) +(define CLONE_CHILD_CLEARTID #x00200000) +(define CLONE_CHILD_SETTID #x01000000) +(define CLONE_NEWNS #x00020000) +(define CLONE_NEWUTS #x04000000) +(define CLONE_NEWIPC #x08000000) +(define CLONE_NEWUSER #x10000000) +(define CLONE_NEWPID #x20000000) +(define CLONE_NEWNET #x40000000) ;; The libc interface to sys_clone is not useful for Scheme programs, so the ;; low-level system call is wrapped instead. -- cgit v1.2.3 From 1cd4027cfdb82d43321c9c20f8bfad97cbd74413 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Fri, 7 Aug 2015 00:10:43 +0200 Subject: ui: Add package-description-string. Provide support for Texinfo's markup in package description. * guix/ui.scm (%text-width): New parameter. (texi->plain-text): New variable. (package->recutils): Use them. (package-description-string): New variable. * emacs/guix-main.scm (%package-param-alist): Use it. * gnu/packages/perl.scm (perl-devel-globaldestruction) (perl-devel-lexalias, perl-exporter-lite): Adapt to Texinfo's markup. * gnu/packages/python.scm (python2-empy): Likewise. --- emacs/guix-main.scm | 2 +- gnu/packages/perl.scm | 6 +++--- gnu/packages/python.scm | 2 +- guix/ui.scm | 50 ++++++++++++++++++++++++++++++++++++------------- 4 files changed, 42 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm index 623da884f6..c9b84d36d9 100644 --- a/emacs/guix-main.scm +++ b/emacs/guix-main.scm @@ -293,7 +293,7 @@ (define %package-param-alist (license . ,package-license-names) (source . ,package-source-names) (synopsis . ,package-synopsis) - (description . ,package-description) + (description . ,package-description-string) (home-url . ,package-home-page) (outputs . ,package-outputs) (non-unique . ,(negate package-unique?)) diff --git a/gnu/packages/perl.scm b/gnu/packages/perl.scm index c528516c15..12fed2b870 100644 --- a/gnu/packages/perl.scm +++ b/gnu/packages/perl.scm @@ -1705,7 +1705,7 @@ (define-public perl-devel-globaldestruction (home-page "http://search.cpan.org/dist/Devel-GlobalDestruction") (synopsis "Provides equivalent of ${^GLOBAL_PHASE} eq 'DESTRUCT' for older perls") (description "Devel::GlobalDestruction provides a function returning the -equivalent of \"${^GLOBAL_PHASE} eq 'DESTRUCT'\" for older perls.") +equivalent of \"$@{^GLOBAL_PHASE@} eq 'DESTRUCT'\" for older perls.") (license (package-license perl)))) (define-public perl-devel-lexalias @@ -1949,7 +1949,7 @@ (define-public perl-eval-closure eval is not without its issues however - it's difficult to control the scope it's used in (which determines which variables are in scope inside the eval), and it's easy to miss compilation errors, since eval catches them and sticks -them in $@ instead. This module attempts to solve these problems. It +them in $@@ instead. This module attempts to solve these problems. It provides an eval_closure function, which evals a string in a clean environment, other than a fixed list of specified variables. Compilation errors are rethrown automatically.") @@ -1993,7 +1993,7 @@ (define-public perl-exporter-lite (description "Exporter::Lite is an alternative to Exporter, intended to provide a lightweight subset of the most commonly-used functionality. It supports -import(), @EXPORT and @EXPORT_OK and not a whole lot else.") +import(), @@EXPORT and @@EXPORT_OK and not a whole lot else.") (home-page (string-append "http://search.cpan.org/~neilb/" "Exporter-Lite-" version)) (license (package-license perl)))) diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index f9ad95118b..feddd1a46a 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -1174,7 +1174,7 @@ (define-public python2-empy "EmPy is a system for embedding Python expressions and statements in template text; it takes an EmPy source file, processes it, and produces output. This is accomplished via expansions, which are special signals to the -EmPy system and are set off by a special prefix (by default the at sign, @). +EmPy system and are set off by a special prefix (by default the at sign, @@). EmPy can expand arbitrary Python expressions and statements in this way, as well as a variety of special forms. Textual data not explicitly delimited in this way is sent unaffected to the output, allowing Python to be used in diff --git a/guix/ui.scm b/guix/ui.scm index 2f757547cf..ca5b844a43 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2015 Alex Kost +;;; Copyright © 2015 Mathieu Lirzin ;;; Copyright © 2014 Deck Pickard ;;; ;;; This file is part of GNU Guix. @@ -45,6 +46,9 @@ (define-module (guix ui) #:use-module (ice-9 regex) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) + #:use-module (texinfo) + #:use-module (texinfo plain-text) + #:use-module (texinfo string-utils) #:export (_ N_ P_ @@ -69,6 +73,7 @@ (define-module (guix ui) switch-symlinks config-directory fill-paragraph + package-description-string string->recutils package->recutils package-specification->name+version+output @@ -775,6 +780,28 @@ (define (maybe-break chr result) ;;; Packages. ;;; +(define %text-width + (make-parameter (or (and=> (getenv "WIDTH") string->number) + 80))) + +(set! (@@ (texinfo plain-text) wrap*) + ;; XXX: Monkey patch this private procedure to let 'package->recutils' + ;; parameterize the fill of description field correctly. + (lambda strings + (let ((indent (fluid-ref (@@ (texinfo plain-text) *indent*)))) + (fill-string (string-concatenate strings) + #:line-width (%text-width) #:initial-indent indent + #:subsequent-indent indent)))) + +(define (texi->plain-text str) + "Return a plain-text representation of texinfo fragment STR." + (stexi->plain-text (texi-fragment->stexi str))) + +(define (package-description-string package) + "Return a plain-text representation of PACKAGE description field." + (and=> (package-description package) + (compose texi->plain-text P_))) + (define (string->recutils str) "Return a version of STR where newlines have been replaced by newlines followed by \"+ \", which makes for a valid multi-line field value in the @@ -787,18 +814,9 @@ (define (string->recutils str) '() str))) -(define* (package->recutils p port - #:optional (width (or (and=> (getenv "WIDTH") - string->number) - 80))) +(define* (package->recutils p port #:optional (width (%text-width))) "Write to PORT a `recutils' record of package P, arranging to fit within WIDTH columns." - (define (description->recutils str) - (let ((str (P_ str))) - (string->recutils - (fill-paragraph str width - (string-length "description: "))))) - (define (dependencies->recutils packages) (let ((list (string-join (map package-full-name (sort packages package (package-synopsis p) P_) ""))) - (format port "description: ~a~%" - (and=> (package-description p) description->recutils)) - (newline port)) + (format port "~a~2%" + (string->recutils + (string-trim-right + (parameterize ((%text-width width)) + (texi->plain-text + (string-append "description: " + (or (and=> (package-description p) P_) + "")))) + #\newline)))) (define (string->generations str) "Return the list of generations matching a pattern in STR. This function -- cgit v1.2.3 From 0c0a1f22cebc0fc2bb78aaf369716d95b7b3fa55 Mon Sep 17 00:00:00 2001 From: Steve Sprang Date: Sat, 5 Sep 2015 11:32:39 -0700 Subject: build: Improve information density and appearance of download progress output. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/download.scm (seconds->string): New function. (byte-count->string): New function. (progress-bar): New function. (throughput->string): Remove function. (progress-proc): Display base file name, elapsed time, and progress bar. Signed-off-by: Ludovic Courtès --- guix/build/download.scm | 79 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 60 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index ae59b0109c..6e85174bc9 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver +;;; Copyright © 2015 Steve Sprang ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,17 +55,46 @@ (define (duration->seconds duration) (+ (time-second duration) (/ (time-nanosecond duration) 1e9))) -(define (throughput->string throughput) - "Given THROUGHPUT, measured in bytes per second, return a string -representing it in a human-readable way." - (if (> throughput 3e6) - (format #f "~,2f MiB/s" (/ throughput (expt 2. 20))) - (format #f "~,0f KiB/s" (/ throughput 1024.0)))) +(define (seconds->string duration) + "Given DURATION in seconds, return a string representing it in 'hh:mm:ss' +format." + (if (not (number? duration)) + "00:00:00" + (let* ((total-seconds (inexact->exact (round duration))) + (extra-seconds (modulo total-seconds 3600)) + (hours (quotient total-seconds 3600)) + (mins (quotient extra-seconds 60)) + (secs (modulo extra-seconds 60))) + (format #f "~2,'0d:~2,'0d:~2,'0d" hours mins secs)))) + +(define (byte-count->string size) + "Given SIZE in bytes, return a string representing it in a human-readable +way." + (let ((KiB 1024.) + (MiB (expt 1024. 2)) + (GiB (expt 1024. 3)) + (TiB (expt 1024. 4))) + (cond + ((< size KiB) (format #f "~dB" (inexact->exact size))) + ((< size MiB) (format #f "~dKiB" (inexact->exact (round (/ size KiB))))) + ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) + ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) + (else (format #f "~,3fTiB" (/ size TiB)))))) + +(define* (progress-bar % #:optional (bar-width 20)) + "Return % as a string representing an ASCII-art progress bar. The total +width of the bar is BAR-WIDTH." + (let* ((fraction (/ % 100)) + (filled (inexact->exact (floor (* fraction bar-width)))) + (empty (- bar-width filled))) + (format #f "[~a~a]" + (make-string filled #\#) + (make-string empty #\space)))) (define* (progress-proc file size #:optional (log-port (current-output-port))) - "Return a procedure to show the progress of FILE's download, which is -SIZE byte long. The returned procedure is suitable for use as an -argument to `dump-port'. The progress report is written to LOG-PORT." + "Return a procedure to show the progress of FILE's download, which is SIZE +bytes long. The returned procedure is suitable for use as an argument to +`dump-port'. The progress report is written to LOG-PORT." ;; XXX: Because of this procedure is often not ;; called as frequently as we'd like too; this is especially bad with Nginx ;; on hydra.gnu.org, which returns whole nars as a single chunk. @@ -83,14 +113,24 @@ (define* (progress-proc file size #:optional (log-port (current-output-port))) (if (number? size) (lambda (transferred cont) (with-elapsed-time elapsed - (let ((% (* 100.0 (/ transferred size))) - (throughput (if elapsed - (/ transferred elapsed) - 0))) + (let* ((% (* 100.0 (/ transferred size))) + (throughput (if elapsed + (/ transferred elapsed) + 0)) + (left (format #f " ~a ~a" + (basename file) + (byte-count->string size))) + (right (format #f "~a/s ~a ~a~6,1f%" + (byte-count->string throughput) + (seconds->string elapsed) + (progress-bar %) %)) + ;; TODO: Make this adapt to the actual terminal width. + (cols 80) + (num-spaces (max 1 (- cols (+ (string-length left) + (string-length right))))) + (gap (make-string num-spaces #\space))) + (format log-port "~a~a~a" left gap right) (display #\cr log-port) - (format log-port "~a\t~5,1f% of ~,1f KiB (~a)" - file % (/ size 1024.0) - (throughput->string throughput)) (flush-output-port log-port) (cont)))) (lambda (transferred cont) @@ -99,9 +139,10 @@ (define* (progress-proc file size #:optional (log-port (current-output-port))) (/ transferred elapsed) 0))) (display #\cr log-port) - (format log-port "~a\t~6,1f KiB transferred (~a)" - file (/ transferred 1024.0) - (throughput->string throughput)) + (format log-port "~a\t~a transferred (~a/s)" + file + (byte-count->string transferred) + (byte-count->string throughput)) (flush-output-port log-port) (cont)))))))) -- cgit v1.2.3 From ef30b974c95d900d446df19b83401b5dff014b7c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Sep 2015 08:49:36 +0200 Subject: pull: Update to the new cgit snapshot URL. * guix/scripts/pull.scm (%snapshot-url): Update to the new URL. --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e6ed8d23eb..e8459e5ffb 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -43,7 +43,7 @@ (define-module (guix scripts pull) (define %snapshot-url ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download" - "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" + "http://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz" ) (define-syntax-rule (with-environment-variable variable value body ...) -- cgit v1.2.3 From a6d0b306c20f236324e4bd661d0f82750ee00e90 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Tue, 21 Jul 2015 20:45:54 -0500 Subject: guix: packages: Add transitive-input-references. * guix/packages.scm (transitive-input-references): New procedure. * gnu/packages/version-control.scm (package-transitive-propagated-labels*) (package-propagated-input-refs): Delete. (git)[arguments]: Adjust to transitive-input-references. --- gnu/packages/version-control.scm | 28 ++++++---------------------- guix/packages.scm | 15 +++++++++++++++ tests/packages.scm | 17 +++++++++++++++++ 3 files changed, 38 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 8d8003fe4c..3c0571bac6 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -98,24 +98,6 @@ (define-public bazaar as well as the classic centralized workflow.") (license gpl2+))) -(define (package-transitive-propagated-labels* package) - "Return a list of the input labels of PACKAGE and its transitive inputs." - (let ((name (package-name package))) - `(,name - ,@(map (match-lambda - ((label (? package? _) . _) - label)) - (package-transitive-propagated-inputs package))))) - -(define (package-propagated-input-refs inputs packages) - "Return a list of (assoc-ref INPUTS ) for each package in -PACKAGES and their propagated inputs." - (map (lambda (l) - `(assoc-ref ,inputs ,l)) - (delete-duplicates ;XXX: efficiency - (append-map package-transitive-propagated-labels* - packages)))) - (define-public git ;; Keep in sync with 'git-manpages'! (package @@ -238,11 +220,13 @@ (define-public git `("PERL5LIB" ":" prefix ,(map (lambda (o) (string-append o "/lib/perl5/site_perl")) (list - ,@(package-propagated-input-refs + ,@(transitive-input-references 'inputs - (list perl-authen-sasl - perl-net-smtp-ssl - perl-io-socket-ssl)))))) + (map (lambda (l) + (assoc l (inputs))) + '("perl-authen-sasl" + "perl-net-smtp-ssl" + "perl-io-socket-ssl"))))))) ;; Tell 'git-submodule' where Perl is. (wrap-program git-sm diff --git a/guix/packages.scm b/guix/packages.scm index 3983d1409a..e466ffeda0 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès ;;; Copyright © 2014, 2015 Mark H Weaver +;;; Copyright © 2015 Eric Bavier ;;; ;;; This file is part of GNU Guix. ;;; @@ -93,6 +94,8 @@ (define-module (guix packages) package-output package-grafts + transitive-input-references + %supported-systems %hydra-supported-systems supported-package? @@ -579,6 +582,18 @@ (define (package-transitive-propagated-inputs package) recursively." (transitive-inputs (package-propagated-inputs package))) +(define (transitive-input-references alist inputs) + "Return a list of (assoc-ref ALIST