diff options
Diffstat (limited to 'guix/import')
-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 |
4 files changed, 146 insertions, 88 deletions
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))) |