diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/asdf.scm | 2 | ||||
| -rw-r--r-- | guix/build/debug-link.scm | 210 | ||||
| -rw-r--r-- | guix/build/graft.scm | 31 | ||||
| -rw-r--r-- | guix/build/svn.scm | 2 | ||||
| -rw-r--r-- | guix/grafts.scm | 17 | ||||
| -rw-r--r-- | guix/import/cpan.scm | 4 | ||||
| -rw-r--r-- | guix/import/github.scm | 92 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 124 | ||||
| -rw-r--r-- | guix/import/json.scm | 14 | ||||
| -rw-r--r-- | guix/inferior.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 37 |
11 files changed, 424 insertions, 114 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index ab0ae57c6e..57e294d74d 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -62,7 +62,7 @@ (define (default-lisp implementation) "Return the default package for the lisp IMPLEMENTATION." - ;; Lazily resolve the binding to avoid a circular dependancy. + ;; Lazily resolve the binding to avoid a circular dependency. (let ((lisp-module (resolve-interface '(gnu packages lisp)))) (module-ref lisp-module implementation))) diff --git a/guix/build/debug-link.scm b/guix/build/debug-link.scm new file mode 100644 index 0000000000..9167737fb3 --- /dev/null +++ b/guix/build/debug-link.scm @@ -0,0 +1,210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build debug-link) + #:use-module (guix elf) + #:use-module ((guix build utils) + #:select (find-files elf-file? make-file-writable)) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (system foreign) + #:use-module (ice-9 match) + #:export (debuglink-crc32 + elf-debuglink + set-debuglink-crc + + graft-debug-links)) + +;;; Commentary: +;;; +;;; This module provides tools to deal with '.gnu_debuglink' sections in ELF +;;; files. These sections are created by 'objcopy --add-gnu-debuglink' to +;;; create separate debug files (info "(gdb) Separate Debug Files"). +;;; +;;; The main facility of this module is 'graft-debug-links', which allows us +;;; to update the CRC that appears in '.gnu_debuglink' sections when grafting, +;;; such that separate debug files remain usable after grafting. Failing to +;;; do that, GDB would complain about CRC mismatch---see +;;; <https://bugs.gnu.org/19973>. +;;; +;;; Code: + +(define %crc32-table + ;; CRC table taken from "(gdb) Separate Debug Files". + ;; TODO: Wouldn't it be nice to generate it "from source" with a macro? + #(#x00000000 #x77073096 #xee0e612c #x990951ba #x076dc419 + #x706af48f #xe963a535 #x9e6495a3 #x0edb8832 #x79dcb8a4 + #xe0d5e91e #x97d2d988 #x09b64c2b #x7eb17cbd #xe7b82d07 + #x90bf1d91 #x1db71064 #x6ab020f2 #xf3b97148 #x84be41de + #x1adad47d #x6ddde4eb #xf4d4b551 #x83d385c7 #x136c9856 + #x646ba8c0 #xfd62f97a #x8a65c9ec #x14015c4f #x63066cd9 + #xfa0f3d63 #x8d080df5 #x3b6e20c8 #x4c69105e #xd56041e4 + #xa2677172 #x3c03e4d1 #x4b04d447 #xd20d85fd #xa50ab56b + #x35b5a8fa #x42b2986c #xdbbbc9d6 #xacbcf940 #x32d86ce3 + #x45df5c75 #xdcd60dcf #xabd13d59 #x26d930ac #x51de003a + #xc8d75180 #xbfd06116 #x21b4f4b5 #x56b3c423 #xcfba9599 + #xb8bda50f #x2802b89e #x5f058808 #xc60cd9b2 #xb10be924 + #x2f6f7c87 #x58684c11 #xc1611dab #xb6662d3d #x76dc4190 + #x01db7106 #x98d220bc #xefd5102a #x71b18589 #x06b6b51f + #x9fbfe4a5 #xe8b8d433 #x7807c9a2 #x0f00f934 #x9609a88e + #xe10e9818 #x7f6a0dbb #x086d3d2d #x91646c97 #xe6635c01 + #x6b6b51f4 #x1c6c6162 #x856530d8 #xf262004e #x6c0695ed + #x1b01a57b #x8208f4c1 #xf50fc457 #x65b0d9c6 #x12b7e950 + #x8bbeb8ea #xfcb9887c #x62dd1ddf #x15da2d49 #x8cd37cf3 + #xfbd44c65 #x4db26158 #x3ab551ce #xa3bc0074 #xd4bb30e2 + #x4adfa541 #x3dd895d7 #xa4d1c46d #xd3d6f4fb #x4369e96a + #x346ed9fc #xad678846 #xda60b8d0 #x44042d73 #x33031de5 + #xaa0a4c5f #xdd0d7cc9 #x5005713c #x270241aa #xbe0b1010 + #xc90c2086 #x5768b525 #x206f85b3 #xb966d409 #xce61e49f + #x5edef90e #x29d9c998 #xb0d09822 #xc7d7a8b4 #x59b33d17 + #x2eb40d81 #xb7bd5c3b #xc0ba6cad #xedb88320 #x9abfb3b6 + #x03b6e20c #x74b1d29a #xead54739 #x9dd277af #x04db2615 + #x73dc1683 #xe3630b12 #x94643b84 #x0d6d6a3e #x7a6a5aa8 + #xe40ecf0b #x9309ff9d #x0a00ae27 #x7d079eb1 #xf00f9344 + #x8708a3d2 #x1e01f268 #x6906c2fe #xf762575d #x806567cb + #x196c3671 #x6e6b06e7 #xfed41b76 #x89d32be0 #x10da7a5a + #x67dd4acc #xf9b9df6f #x8ebeeff9 #x17b7be43 #x60b08ed5 + #xd6d6a3e8 #xa1d1937e #x38d8c2c4 #x4fdff252 #xd1bb67f1 + #xa6bc5767 #x3fb506dd #x48b2364b #xd80d2bda #xaf0a1b4c + #x36034af6 #x41047a60 #xdf60efc3 #xa867df55 #x316e8eef + #x4669be79 #xcb61b38c #xbc66831a #x256fd2a0 #x5268e236 + #xcc0c7795 #xbb0b4703 #x220216b9 #x5505262f #xc5ba3bbe + #xb2bd0b28 #x2bb45a92 #x5cb36a04 #xc2d7ffa7 #xb5d0cf31 + #x2cd99e8b #x5bdeae1d #x9b64c2b0 #xec63f226 #x756aa39c + #x026d930a #x9c0906a9 #xeb0e363f #x72076785 #x05005713 + #x95bf4a82 #xe2b87a14 #x7bb12bae #x0cb61b38 #x92d28e9b + #xe5d5be0d #x7cdcefb7 #x0bdbdf21 #x86d3d2d4 #xf1d4e242 + #x68ddb3f8 #x1fda836e #x81be16cd #xf6b9265b #x6fb077e1 + #x18b74777 #x88085ae6 #xff0f6a70 #x66063bca #x11010b5c + #x8f659eff #xf862ae69 #x616bffd3 #x166ccf45 #xa00ae278 + #xd70dd2ee #x4e048354 #x3903b3c2 #xa7672661 #xd06016f7 + #x4969474d #x3e6e77db #xaed16a4a #xd9d65adc #x40df0b66 + #x37d83bf0 #xa9bcae53 #xdebb9ec5 #x47b2cf7f #x30b5ffe9 + #xbdbdf21c #xcabac28a #x53b39330 #x24b4a3a6 #xbad03605 + #xcdd70693 #x54de5729 #x23d967bf #xb3667a2e #xc4614ab8 + #x5d681b02 #x2a6f2b94 #xb40bbe37 #xc30c8ea1 #x5a05df1b + #x2d02ef8d)) + +(define (debuglink-crc32 port) + "Compute the 32-bit CRC used in in '.gnu_debuglink' over the data read from +PORT and return it." ;(info "(gdb) Separate Debug Files") + (let loop ((crc #xffffffff)) + (let ((byte (get-u8 port))) + (if (eof-object? byte) + (logand (lognot crc) #xffffffff) + (let* ((index (logand (logxor crc byte) #xff)) + (lhs (vector-ref %crc32-table index))) + (loop (logxor lhs (ash crc -8)))))))) + +(define (section-contents elf section) ;XXX: copied from linux-modules.scm + "Return the contents of SECTION in ELF as a bytevector." + (let* ((contents (make-bytevector (elf-section-size section)))) + (bytevector-copy! (elf-bytes elf) (elf-section-offset section) + contents 0 + (elf-section-size section)) + contents)) + +(define null-terminated-bytevector->string + (compose pointer->string bytevector->pointer)) + +(define (elf-debuglink elf) + "Return two values: the '.gnu_debuglink' file name of ELF and its CRC. +Return #f for both if ELF lacks a '.gnu_debuglink' section." + (let ((section (elf-section-by-name elf ".gnu_debuglink"))) + (if section + (let ((size (elf-section-size section)) + (bv (section-contents elf section)) + (endianness (elf-byte-order elf))) + (values (null-terminated-bytevector->string bv) + (bytevector-u32-ref bv (- size 4) endianness))) + (values #f #f)))) + +(define (elf-debuglink-crc-offset elf) + "Return the offset of the '.gnu_debuglink' 32-bit CRC, or #f if ELF lacks a +'.gnu_debuglink' section." + (let ((section (elf-section-by-name elf ".gnu_debuglink"))) + (and section + (+ (elf-section-offset section) + (elf-section-size section) + -4)))) + +(define (set-debuglink-crc file debug-file) + "Compute the CRC of DEBUG-FILE and set it as the '.gnu_debuglink' CRC in +FILE." + (let* ((elf (parse-elf (call-with-input-file file get-bytevector-all))) + (offset (elf-debuglink-crc-offset elf))) + (and offset + (let* ((crc (call-with-input-file debug-file debuglink-crc32)) + (bv (make-bytevector 4))) + (bytevector-u32-set! bv 0 crc (elf-byte-order elf)) + (let ((port (open file O_RDWR))) + (set-port-position! port offset) + (put-bytevector port bv) + (close-port port)))))) + + +;;; +;;; Updating debuglink CRC. +;;; + +(define (find-elf-files outputs) + "Return the list of ELF files found in OUTPUTS, a list of top-level store +directories." + (define directories + (append-map (lambda (output) + (list (string-append output "/bin") + (string-append output "/sbin") + (string-append output "/lib") + (string-append output "/libexec"))) + outputs)) + + (append-map (lambda (directory) + (filter elf-file? + (with-error-to-port (%make-void-port "w") + (lambda () + (find-files directory))))) + directories)) + +(define* (graft-debug-links old-outputs new-outputs mapping + #:key (log-port (current-error-port))) + "Update the '.gnu_debuglink' CRCs found in ELF files of NEW-OUTPUTS, +provided NEW-OUTPUTS contains a \"debug\" output, such that those CRCs match +those of the corresponding '.debug' files found in the \"debug\" output. + +This procedure is meant to be used as a \"grafting hook\" by (guix build +graft)." + (match (assoc-ref new-outputs "debug") + (#f #t) ;nothing to do + (debug-directory + (let ((files (find-elf-files (filter-map (match-lambda + (("debug" . _) + #f) + ((name . directory) + directory)) + new-outputs)))) + (for-each (lambda (file) + (let ((debug (string-append debug-directory + "/lib/debug" file ".debug"))) + (when (file-exists? debug) + (format log-port + "updating '.gnu_debuglink' CRC in '~a'~%" + file) + (make-file-writable file) + (set-debuglink-crc file debug)))) + files))))) diff --git a/guix/build/graft.scm b/guix/build/graft.scm index e567bff4f4..c119ee71d1 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -19,6 +19,7 @@ (define-module (guix build graft) #:use-module (guix build utils) + #:use-module (guix build debug-link) #:use-module (rnrs bytevectors) #:use-module (ice-9 vlist) #:use-module (ice-9 match) @@ -27,7 +28,8 @@ #:use-module (srfi srfi-1) ; list library #:use-module (srfi srfi-26) ; cut and cute #:export (replace-store-references - rewrite-directory)) + rewrite-directory + graft)) ;;; Commentary: ;;; @@ -321,4 +323,29 @@ file name pairs." #:directories? #t)) (rename-matching-files output mapping)) +(define %graft-hooks + ;; Default list of hooks run after grafting. + (list graft-debug-links)) + +(define* (graft old-outputs new-outputs mapping + #:key (log-port (current-output-port)) + (hooks %graft-hooks)) + "Apply the grafts described by MAPPING on OLD-OUTPUTS, leading to +NEW-OUTPUTS. MAPPING must be a list of file name pairs; OLD-OUTPUTS and +NEW-OUTPUTS are lists of output name/file name pairs." + (for-each (lambda (input output) + (format log-port "grafting '~a' -> '~a'...~%" input output) + (force-output) + (rewrite-directory input output mapping)) + (match old-outputs + (((names . files) ...) + files)) + (match new-outputs + (((names . files) ...) + files))) + (for-each (lambda (hook) + (hook old-outputs new-outputs mapping + #:log-port log-port)) + hooks)) + ;;; graft.scm ends here diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 252d1d4ee5..913f89471b 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -51,7 +51,7 @@ valid Subversion revision. Return #t on success, #f otherwise." ;; of the repo. Since we want a fixed output, this directory needs ;; to be taken out. (with-directory-excursion directory - (delete-file-recursively ".svn")) + (for-each delete-file-recursively (find-files "." "^\\.svn$" #:directories? #t))) #t) diff --git a/guix/grafts.scm b/guix/grafts.scm index d6b0e93e8d..f303e925f1 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -117,16 +117,7 @@ are not recursively applied to dependencies of DRV." (cons (assoc-ref old-outputs name) file))) %outputs)))) - (for-each (lambda (input output) - (format #t "grafting '~a' -> '~a'...~%" input output) - (force-output) - (rewrite-directory input output mapping)) - (match old-outputs - (((names . files) ...) - files)) - (match %outputs - (((names . files) ...) - files)))))) + (graft old-outputs %outputs mapping)))) (define add-label (cut cons "x" <>)) @@ -139,7 +130,9 @@ are not recursively applied to dependencies of DRV." #:system system #:guile-for-build guile #:modules '((guix build graft) - (guix build utils)) + (guix build utils) + (guix build debug-link) + (guix elf)) #:inputs `(,@(map (lambda (out) `("x" ,drv ,out)) outputs) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 08bed8767c..d0ff64ed05 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> -;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -117,7 +117,7 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name))) (define (cpan-home name) - (string-append "http://search.cpan.org/dist/" name "/")) + (string-append "https://metacpan.org/release/" name)) (define (cpan-source-url meta) "Return the download URL for a module's source tarball." diff --git a/guix/import/github.scm b/guix/import/github.scm index ef226911b9..af9f56e1dc 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,41 +120,73 @@ repository separated by a forward slash, from a string URL of the form ;; limit, or #f. (make-parameter (getenv "GUIX_GITHUB_TOKEN"))) +(define (fetch-releases-or-tags url) + "Fetch the list of \"releases\" or, if it's empty, the list of tags for the +repository at URL. Return the corresponding JSON dictionaries (hash tables), +or #f if the information could not be retrieved. + +We look at both /releases and /tags because the \"release\" feature of GitHub +is little used; often, people simply provide a tag. What's confusing is that +tags show up in the \"Releases\" tab of the web UI. For instance, +'https://github.com/aconchillo/guile-json/releases' shows a number of +\"releases\" (really: tags), whereas +'https://api.github.com/repos/aconchillo/guile-json/releases' returns the +empty list." + (define release-url + (string-append "https://api.github.com/repos/" + (github-user-slash-repository url) + "/releases")) + (define tag-url + (string-append "https://api.github.com/repos/" + (github-user-slash-repository url) + "/tags")) + + (define headers + ;; Ask for version 3 of the API as suggested at + ;; <https://developer.github.com/v3/>. + `((Accept . "application/vnd.github.v3+json") + (user-agent . "GNU Guile"))) + + (define (decorate url) + (if (%github-token) + (string-append url "?access_token=" (%github-token)) + url)) + + (match (json-fetch (decorate release-url) #:headers headers) + (() + ;; We got the empty list, presumably because the user didn't use GitHub's + ;; "release" mechanism, but hopefully they did use Git tags. + (json-fetch (decorate tag-url) #:headers headers)) + (x x))) + (define (latest-released-version url package-name) "Return a string of the newest released version name given a string URL like 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of the package e.g. 'bedtools2'. Return #f if there is no releases" - (let* ((token (%github-token)) - (api-url (string-append - "https://api.github.com/repos/" - (github-user-slash-repository url) - "/releases")) - (json (json-fetch - (if token - (string-append api-url "?access_token=" token) - api-url)))) + (let* ((json (fetch-releases-or-tags url))) (if (eq? json #f) - (if token + (if (%github-token) (error "Error downloading release information through the GitHub API when using a GitHub token") (error "Error downloading release information through the GitHub API. This may be fixed by using an access token and setting the environment variable GUIX_GITHUB_TOKEN, for instance one procured from https://github.com/settings/tokens")) - (let ((proper-releases - (filter - (lambda (x) - ;; example pre-release: - ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1 - ;; or an all-prerelease set - ;; https://github.com/powertab/powertabeditor/releases - (not (hash-ref x "prerelease"))) - json))) - (match proper-releases - (() ;empty release list + (let loop ((releases + (filter + (lambda (x) + ;; example pre-release: + ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1 + ;; or an all-prerelease set + ;; https://github.com/powertab/powertabeditor/releases + (not (hash-ref x "prerelease"))) + json))) + (match releases + (() ;empty release list #f) - ((release . rest) ;one or more releases - (let ((tag (hash-ref release "tag_name")) + ((release . rest) ;one or more releases + (let ((tag (or (hash-ref release "tag_name") ;a "release" + (hash-ref release "name"))) ;a tag (name-length (string-length package-name))) ;; some tags include the name of the package e.g. "fdupes-1.51" ;; so remove these @@ -164,8 +196,16 @@ https://github.com/settings/tokens")) (substring tag (+ name-length 1)) ;; some tags start with a "v" e.g. "v0.25.0" ;; where some are just the version number - (if (eq? (string-ref tag 0) #\v) - (substring tag 1) tag))))))))) + (if (string-prefix? "v" tag) + (substring tag 1) + + ;; Finally, reject tags that don't start with a digit: + ;; they may not represent a release. + (if (and (not (string-null? tag)) + (char-set-contains? char-set:digit + (string-ref tag 0))) + tag + (loop rest))))))))))) (define (latest-release pkg) "Return an <upstream-source> for the latest release of PKG." diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 3b138f8c98..3c00f680bf 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -30,15 +30,17 @@ #:use-module ((guix utils) #:select (package-name->name+version canonical-newline-port)) #:use-module (guix http-client) - #:use-module ((guix import utils) #:select (factorize-uri)) + #:use-module ((guix import utils) #:select (factorize-uri recursive-import)) #:use-module (guix import cabal) #:use-module (guix store) #:use-module (guix hash) #:use-module (guix base32) + #:use-module (guix memoization) #:use-module (guix upstream) #:use-module (guix packages) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (hackage->guix-package + hackage-recursive-import %hackage-updater guix-package->hackage-name @@ -205,32 +207,34 @@ representation of a Cabal file as produced by 'read-cabal'." (define source-url (hackage-source-url name version)) + (define hackage-dependencies + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + (cut cabal-dependencies->names <>)) + cabal)) + + (define hackage-native-dependencies + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + ;; FIXME: Check include-test-dependencies? + (lambda (cabal) + (append (if include-test-dependencies? + (cabal-test-dependencies->names cabal) + '()) + (cabal-custom-setup-dependencies->names cabal)))) + cabal)) + (define dependencies - (let ((names - (map hackage-name->package-name - ((compose (cut filter-dependencies <> - (cabal-package-name cabal)) - (cut cabal-dependencies->names <>)) - cabal)))) - (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) - names))) + (map (lambda (name) + (list name (list 'unquote (string->symbol name)))) + (map hackage-name->package-name + hackage-dependencies))) (define native-dependencies - (let ((names - (map hackage-name->package-name - ((compose (cut filter-dependencies <> - (cabal-package-name cabal)) - ;; FIXME: Check include-test-dependencies? - (lambda (cabal) - (append (if include-test-dependencies? - (cabal-test-dependencies->names cabal) - '()) - (cabal-custom-setup-dependencies->names cabal)))) - cabal)))) - (map (lambda (name) - (list name (list 'unquote (string->symbol name)))) - names))) + (map (lambda (name) + (list name (list 'unquote (string->symbol name)))) + (map hackage-name->package-name + hackage-native-dependencies))) (define (maybe-inputs input-type inputs) (match inputs @@ -247,31 +251,35 @@ representation of a Cabal file as produced by 'read-cabal'." (let ((tarball (with-store store (download-to-store store source-url)))) - `(package - (name ,(hackage-name->package-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) - (sha256 - (base32 - ,(if tarball - (bytevector->nix-base32-string (file-sha256 tarball)) - "failed to download tar archive"))))) - (build-system haskell-build-system) - ,@(maybe-inputs 'inputs dependencies) - ,@(maybe-inputs 'native-inputs native-dependencies) - ,@(maybe-arguments) - (home-page ,(cabal-package-home-page cabal)) - (synopsis ,(cabal-package-synopsis cabal)) - (description ,(cabal-package-description cabal)) - (license ,(string->license (cabal-package-license cabal)))))) + (values + `(package + (name ,(hackage-name->package-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(if tarball + (bytevector->nix-base32-string (file-sha256 tarball)) + "failed to download tar archive"))))) + (build-system haskell-build-system) + ,@(maybe-inputs 'inputs dependencies) + ,@(maybe-inputs 'native-inputs native-dependencies) + ,@(maybe-arguments) + (home-page ,(cabal-package-home-page cabal)) + (synopsis ,(cabal-package-synopsis cabal)) + (description ,(cabal-package-description cabal)) + (license ,(string->license (cabal-package-license cabal)))) + (append hackage-dependencies hackage-native-dependencies)))) -(define* (hackage->guix-package package-name #:key - (include-test-dependencies? #t) - (port #f) - (cabal-environment '())) - "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the +(define hackage->guix-package + (memoize + (lambda* (package-name #:key + (include-test-dependencies? #t) + (port #f) + (cabal-environment '())) + "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the called with keyword parameter PORT, from PORT. Return the `package' S-expression corresponding to that package, or #f on failure. CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal @@ -281,13 +289,19 @@ symbol 'true' or 'false'. The value associated with other keys has to conform to the Cabal file format definition. The default value associated with the keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\" respectively." - (let ((cabal-meta (if port - (read-cabal (canonical-newline-port port)) - (hackage-fetch package-name)))) - (and=> cabal-meta (compose (cut hackage-module->sexp <> - #:include-test-dependencies? - include-test-dependencies?) - (cut eval-cabal <> cabal-environment))))) + (let ((cabal-meta (if port + (read-cabal (canonical-newline-port port)) + (hackage-fetch package-name)))) + (and=> cabal-meta (compose (cut hackage-module->sexp <> + #:include-test-dependencies? + include-test-dependencies?) + (cut eval-cabal <> cabal-environment))))))) + +(define* (hackage-recursive-import package-name . args) + (recursive-import package-name #f + #:repo->guix-package (lambda (name repo) + (apply hackage->guix-package (cons name args))) + #:guix-name hackage-name->package-name)) (define (hackage-package? package) "Return #t if PACKAGE is a Haskell package from Hackage." diff --git a/guix/import/json.scm b/guix/import/json.scm index 3f2ab1e3ea..4f96a513df 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,17 +26,20 @@ #:export (json-fetch json-fetch-alist)) -(define (json-fetch url) +(define* (json-fetch url + ;; Note: many websites returns 403 if we omit a + ;; 'User-Agent' header. + #:key (headers `((user-agent . "GNU Guile") + (Accept . "application/json")))) "Return a representation of the JSON resource URL (a list or hash table), or -#f if URL returns 403 or 404." +#f if URL returns 403 or 404. HEADERS is a list of HTTP headers to pass in +the query." (guard (c ((and (http-get-error? c) (let ((error (http-get-error-code c))) (or (= 403 error) (= 404 error)))) #f)) - ;; Note: many websites returns 403 if we omit a 'User-Agent' header. - (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile") - (Accept . "application/json")))) + (let* ((port (http-fetch url #:headers headers)) (result (json->scm port))) (close-port port) result))) diff --git a/guix/inferior.scm b/guix/inferior.scm index 629c2c4313..05c8d65deb 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -87,7 +87,10 @@ equivalent. Return #f if the inferior could not be launched." (define pipe (inferior-pipe directory command)) - (setvbuf pipe _IOLBF) + (cond-expand + ((and guile-2 (not guile-2.2)) #t) + (else (setvbuf pipe 'line))) + (match (read pipe) (('repl-version 0 rest ...) (let ((result (inferior 'pipe pipe (cons 0 rest)))) diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 969f637846..f4aac61078 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-hackage)) @@ -57,6 +59,8 @@ version.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -s, --stdin read from standard input")) (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) @@ -89,6 +93,9 @@ version.\n")) (alist-cons 'cabal-environment (read/eval arg) (alist-delete 'cabal-environment result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -107,15 +114,27 @@ version.\n")) %default-options)) (define (run-importer package-name opts error-fn) - (let ((sexp (hackage->guix-package - package-name - #:include-test-dependencies? - (assoc-ref opts 'include-test-dependencies?) - #:port (if (assoc-ref opts 'read-from-stdin?) - (current-input-port) - #f) - #:cabal-environment - (assoc-ref opts 'cabal-environment)))) + (let* ((arguments (list + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?) + #:port (if (assoc-ref opts 'read-from-stdin?) + (current-input-port) + #f) + #:cabal-environment + (assoc-ref opts 'cabal-environment))) + (sexp (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (apply hackage-recursive-import arguments)))) + ;; Single import + (apply hackage->guix-package arguments)))) (unless sexp (error-fn)) sexp)) |