diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/cabal.scm | 84 | ||||
| -rw-r--r-- | guix/import/cran.scm | 279 | ||||
| -rw-r--r-- | guix/import/elpa.scm | 8 | ||||
| -rw-r--r-- | guix/import/gnu.scm | 30 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 48 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 99 |
6 files changed, 333 insertions, 215 deletions
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 45d644a2c7..c20e074e18 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -30,6 +30,7 @@ #:use-module (srfi srfi-9 gnu) #:use-module (system base lalr) #:use-module (rnrs enums) + #:use-module (guix utils) #:export (read-cabal eval-cabal @@ -138,7 +139,7 @@ to the stack." "Generate a parser for Cabal files." (lalr-parser ;; --- token definitions - (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION + (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE (right: IF FLAG EXEC TEST-SUITE SOURCE-REPO BENCHMARK LIB OCURLY) (left: OR) (left: PROPERTY AND) @@ -206,6 +207,8 @@ to the stack." (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ()) (IF tests open exprs close) : `(if ,$2 ,$4 ())) (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) + (TRUE) : 'true + (FALSE) : 'false (TEST OPAREN ID RELATION VERSION CPAREN) : `(,$1 ,(string-append $3 " " $4 " " $5)) (TEST OPAREN ID RELATION VERSION AND RELATION VERSION CPAREN) @@ -224,19 +227,24 @@ to the stack." "This function can be called when the next character on PORT is #\newline and returns the indentation of the line starting after the #\newline character. Discard (and consume) empty and comment lines." - (let ((initial-newline (string (read-char port)))) - (let loop ((char (peek-char port)) - (word "")) - (cond ((eqv? char #\newline) (read-char port) - (loop (peek-char port) "")) - ((or (eqv? char #\space) (eqv? char #\tab)) - (let ((c (read-char port))) - (loop (peek-char port) (string-append word (string c))))) - ((comment-line port char) (loop (peek-char port) "")) - (else - (let ((len (string-length word))) - (unread-string (string-append initial-newline word) port) - len)))))) + (if (eof-object? (peek-char port)) + ;; If the file is missing the #\newline on the last line, add it and act + ;; as if it were there. This is needed for proper operation of + ;; indentation based block recognition (based on ‘port-column’). + (begin (unread-char #\newline port) (read-char port) 0) + (let ((initial-newline (string (read-char port)))) + (let loop ((char (peek-char port)) + (word "")) + (cond ((eqv? char #\newline) (read-char port) + (loop (peek-char port) "")) + ((or (eqv? char #\space) (eqv? char #\tab)) + (let ((c (read-char port))) + (loop (peek-char port) (string-append word (string c))))) + ((comment-line port char) (loop (peek-char port) "")) + (else + (let ((len (string-length word))) + (unread-string (string-append initial-newline word) port) + len))))))) (define* (read-value port value min-indent #:optional (separator " ")) "The next character on PORT must be #\newline. Append to VALUE the @@ -325,7 +333,7 @@ matching a string against the created regexp." (make-regexp pat)))) (cut regexp-exec rx <>))) -(define is-property (make-rx-matcher "([a-z0-9-]+):[ \t]*(\\w?.*)$" +(define is-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?.*)$" regexp/icase)) (define is-flag (make-rx-matcher "^flag +([a-z0-9_-]+)" @@ -350,21 +358,32 @@ matching a string against the created regexp." (define (is-if s) (string-ci=? s "if")) +(define (is-true s) (string-ci=? s "true")) + +(define (is-false s) (string-ci=? s "false")) + (define (is-and s) (string=? s "&&")) (define (is-or s) (string=? s "||")) -(define (is-id s) +(define (is-id s port) (let ((cabal-reserved-words '("if" "else" "library" "flag" "executable" "test-suite" - "source-repository" "benchmark"))) + "source-repository" "benchmark")) + (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) + (c (peek-char port))) + (unread-string spaces port) (and (every (cut string-ci<> s <>) cabal-reserved-words) - (not (char=? (last (string->list s)) #\:))))) + (and (not (char=? (last (string->list s)) #\:)) + (not (char=? #\: c)))))) (define (is-test s port) (let ((tests-rx (make-regexp "os|arch|flag|impl")) + (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) - (and (regexp-exec tests-rx s) (char=? #\( c)))) + (if (and (regexp-exec tests-rx s) (char=? #\( c)) + #t + (begin (unread-string spaces port) #f)))) ;; Lexers for individual tokens. @@ -424,6 +443,10 @@ string with the read characters." (define (lex-if loc) (make-lexical-token 'IF loc #f)) +(define (lex-true loc) (make-lexical-token 'TRUE loc #t)) + +(define (lex-false loc) (make-lexical-token 'FALSE loc #f)) + (define (lex-and loc) (make-lexical-token 'AND loc #f)) (define (lex-or loc) (make-lexical-token 'OR loc #f)) @@ -486,12 +509,14 @@ location." (define (lex-word port loc) "Process tokens which can be recognized by reading the next word form PORT. LOC is the current port location." - (let* ((w (read-delimited " ()\t\n" port 'peek))) + (let* ((w (read-delimited " <>=()\t\n" port 'peek))) (cond ((is-if w) (lex-if loc)) ((is-test w port) (lex-test w loc)) + ((is-true w) (lex-true loc)) + ((is-false w) (lex-false loc)) ((is-and w) (lex-and loc)) ((is-or w) (lex-or loc)) - ((is-id w) (lex-id w loc)) + ((is-id w port) (lex-id w loc)) (else (unread-string w port) #f)))) (define (lex-line port loc) @@ -684,11 +709,18 @@ the ordering operation and the version." ((spec-name spec-op spec-ver) (comp-spec-name+op+version haskell))) (if (and spec-ver comp-ver) - (eval-string - (string-append "(string" spec-op " \"" comp-name "\"" - " \"" spec-name "-" spec-ver "\")")) + (cond + ((not (string= spec-name comp-name)) #f) + ((string= spec-op "==") (string= spec-ver comp-ver)) + ((string= spec-op ">=") (version>=? comp-ver spec-ver)) + ((string= spec-op ">") (version>? comp-ver spec-ver)) + ((string= spec-op "<=") (not (version>? comp-ver spec-ver))) + ((string= spec-op "<") (not (version>=? comp-ver spec-ver))) + (else + (raise (condition + (&message (message "Failed to evaluate 'impl' test.")))))) (string-match spec-name comp-name)))) - + (define (cabal-flags) (make-cabal-section cabal-sexp 'flag)) @@ -714,6 +746,8 @@ the ordering operation and the version." (('os name) (os name)) (('arch name) (arch name)) (('impl name) (impl name)) + ('true #t) + ('false #f) (('not name) (not (eval name))) ;; 'and' and 'or' aren't functions, thus we can't use apply (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 6284c9eef3..845ecb5832 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -20,26 +20,26 @@ (define-module (guix import cran) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module ((ice-9 rdelim) #:select (read-string)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) - #: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) + #:use-module ((guix build-system r) #:select (cran-uri)) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (gnu packages) #:export (cran->guix-package %cran-updater)) ;;; Commentary: ;;; ;;; Generate a package declaration template for the latest version of an R -;;; package on CRAN, using the HTML description downloaded from +;;; package on CRAN, using the DESCRIPTION file downloaded from ;;; cran.r-project.org. ;;; ;;; Code: @@ -51,16 +51,47 @@ ("Apache License 2.0" 'asl2.0) ("BSD_2_clause" 'bsd-2) ("BSD_3_clause" 'bsd-3) + ("GPL" (list 'gpl2+ 'gpl3+)) + ("GPL (>= 2)" 'gpl2+) + ("GPL (>= 3)" 'gpl3+) ("GPL-2" 'gpl2+) ("GPL-3" 'gpl3+) ("LGPL-2" 'lgpl2.0+) ("LGPL-2.1" 'lgpl2.1+) ("LGPL-3" 'lgpl3+) + ("LGPL (>= 2)" 'lgpl2.0+) + ("LGPL (>= 3)" 'lgpl3+) ("MIT" 'x11) + ("MIT + file LICENSE" 'x11) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) (_ #f))) + +(define (description->alist description) + "Convert a DESCRIPTION string into an alist." + (let ((lines (string-split description #\newline)) + (parse (lambda (line acc) + (if (string-null? line) acc + ;; Keys usually start with a capital letter and end with + ;; ":". There are some exceptions, unfortunately (such + ;; as "biocViews"). There are no blanks in a key. + (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line) + ;; New key/value pair + (let* ((pos (string-index line #\:)) + (key (string-take line pos)) + (value (string-drop line (+ 1 pos)))) + (cons (cons key + (string-trim-both value)) + acc)) + ;; This is a continuation of the previous pair + (match-let ((((key . value) . rest) acc)) + (cons (cons key (string-join + (list value + (string-trim-both line)))) + rest))))))) + (fold parse '() lines))) + (define (format-inputs names) "Generate a sorted list of package inputs from a list of package NAMES." (map (lambda (name) @@ -76,125 +107,94 @@ package definition." ((package-inputs ...) `((,type (,'quasiquote ,(format-inputs package-inputs))))))) -(define (table-datum tree label) - "Extract the datum node following a LABEL in the sxml table TREE. Only the -first cell of a table row is considered a label cell." - ((node-pos 1) - ((sxpath `(xhtml:tr - (xhtml:td 1) ; only first cell can contain label - (equal? ,label) - ,(node-parent tree) ; go up to label cell - ,(node-parent tree) ; go up to matching row - (xhtml:td 2))) ; select second cell - tree))) - (define %cran-url "http://cran.r-project.org/web/packages/") (define (cran-fetch name) - "Return an sxml representation of the CRAN page for the R package NAME, -or #f on failure. NAME is case-sensitive." + "Return an alist of the contents of the DESCRIPTION file for the R package +NAME, or #f on failure. NAME is case-sensitive." ;; This API always returns the latest release of the module. - (let ((cran-url (string-append %cran-url name "/"))) - (false-if-exception - (xml->sxml (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 (downloads->url downloads) - "Extract from DOWNLOADS, the downloads item of the CRAN sxml tree, the -download 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))) - -(define (nodes->text nodeset) - "Return the concatenation of the text nodes among NODESET." - (string-join ((sxpath '(// *text*)) nodeset) " ")) - -(define (cran-sxml->sexp sxml) - "Return the `package' s-expression for a CRAN package from the SXML -representation of the package page." + (let ((url (string-append %cran-url name "/DESCRIPTION"))) + (description->alist (read-string (http-fetch url))))) + +(define (listify meta field) + "Look up FIELD in the alist META. If FIELD contains a comma-separated +string, turn it into a list and strip off parenthetic expressions. Return the +empty list when the FIELD cannot be found." + (let ((value (assoc-ref meta field))) + (if (not value) + '() + ;; Strip off parentheses + (let ((items (string-split (regexp-substitute/global + #f "( *\\([^\\)]+\\)) *" + value 'pre 'post) + #\,))) + ;; When there is whitespace inside of items it is probably because + ;; this was not an actual list to begin with. + (remove (cut string-any char-set:whitespace <>) + (map string-trim-both items)))))) + +(define (beautify-description description) + "Improve the package DESCRIPTION by turning a beginning sentence fragment +into a proper sentence and by using two spaces between sentences." + (let ((cleaned (if (string-prefix? "A " description) + (string-append "This package provides a" + (substring description 1)) + description))) + ;; Use double spacing between sentences + (regexp-substitute/global #f "\\. \\b" + cleaned 'pre ". " 'post))) + +(define (description->package meta) + "Return the `package' s-expression for a CRAN package from the alist META, +which was derived from the R package's DESCRIPTION file." (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 (downloads->url downloads)) - (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 (cran-uri ,name 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))))) + (let* ((name (assoc-ref meta "Package")) + (synopsis (assoc-ref meta "Title")) + (version (assoc-ref meta "Version")) + (license (string->license (assoc-ref meta "License"))) + ;; Some packages have multiple home pages. Some have none. + (home-page (match (listify meta "URL") + ((url rest ...) url) + (_ (string-append %cran-url name)))) + (source-url (match (cran-uri name version) + ((url rest ...) url) + (_ #f))) + (tarball (with-store store (download-to-store store source-url))) + (sysdepends (map string-downcase (listify meta "SystemRequirements"))) + (propagate (map guix-name (lset-union equal? + (listify meta "Imports") + (listify meta "LinkingTo") + (delete "R" + (listify meta "Depends")))))) + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (cran-uri ,name version)) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (properties ,`(,'quasiquote ((,'upstream-name . ,name)))) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs propagate 'propagated-inputs) + (home-page ,(if (string-null? home-page) + (string-append %cran-url name) + home-page)) + (synopsis ,synopsis) + (description ,(beautify-description (assoc-ref meta "Description"))) + (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))) + (and=> module-meta description->package))) ;;; @@ -203,32 +203,33 @@ representation of the package page." (define (latest-release package) "Return an <upstream-source> for the latest release of PACKAGE." - (define name - (if (string-prefix? "r-" package) - (string-drop package 2) - package)) - - (define sxml - (cran-fetch name)) - - (and sxml - (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 ((version (nodes->text (table-datum summary "Version:"))) - (url (downloads->url downloads))) - ;; CRAN does not provide signatures. - (upstream-source - (package package) - (version version) - (urls (list url))))))) + + (define (package->cran-name package) + (match (package-source package) + ((? origin? origin) + (match (origin-uri origin) + ((url rest ...) + (let ((end (string-rindex url #\_)) + (start (string-rindex url #\/))) + ;; The URL ends on + ;; (string-append "/" name "_" version ".tar.gz") + (substring url start end))) + (_ #f))) + (_ #f))) + + (define cran-name + (package->cran-name (specification->package package))) + + (define meta + (cran-fetch cran-name)) + + (and meta + (let ((version (assoc-ref meta "Version"))) + ;; CRAN does not provide signatures. + (upstream-source + (package package) + (version version) + (urls (cran-uri cran-name version)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." @@ -236,8 +237,10 @@ representation of the package page." (string-prefix? "r-" (package-name package))) (define %cran-updater - (upstream-updater 'cran - cran-package? - latest-release)) + (upstream-updater + (name 'cran) + (description "Updater for CRAN packages") + (pred cran-package?) + (latest latest-release))) ;;; cran.scm ends here diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 37fc2b80fe..8c10668293 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -272,8 +272,10 @@ as \"debbugs\"." (define %elpa-updater ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org ;; because for other repositories, we typically grab the source elsewhere. - (upstream-updater 'elpa - package-from-gnu.org? - latest-release)) + (upstream-updater + (name 'elpa) + (description "Updater for ELPA packages") + (pred package-from-gnu.org?) + (latest latest-release))) ;;; elpa.scm ends here diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 7160fcf7ba..834f0ae5cf 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,11 +23,13 @@ #:use-module (guix store) #:use-module (guix hash) #:use-module (guix base32) + #:use-module (guix upstream) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (web uri) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:export (gnu->guix-package)) @@ -47,7 +49,7 @@ (define (preferred-archive-type release) "Return the preferred type of archive for downloading RELEASE." - (find (cute member <> (gnu-release-archive-types release)) + (find (cute member <> (upstream-source-archive-types release)) '("xz" "lz" "bz2" "tbz2" "gz" "tgz" "Z"))) (define* (gnu-package->sexp package release @@ -60,21 +62,29 @@ (define url-base ;; XXX: We assume that RELEASE's directory starts with "/gnu". - (string-append "mirror:/" (gnu-release-directory release) + (string-append "mirror:/" + (match (upstream-source-urls release) + ((url rest ...) + (dirname (uri-path (string->uri url))))) "/" name "-")) (define archive-type (preferred-archive-type release)) + (define url + (find (cut string-suffix? archive-type <>) + (upstream-source-urls release))) + + (define sig-url + (find (cute string-suffix? (string-append archive-type ".sig") <>) + (upstream-source-signature-urls release))) + (let ((tarball (with-store store - (download-tarball store name - (gnu-release-directory release) - (gnu-release-version release) - #:archive-type archive-type + (download-tarball store url sig-url #:key-download key-download)))) `(package (name ,name) - (version ,(gnu-release-version release)) + (version ,(upstream-source-version release)) (source (origin (method url-fetch) (uri (string-append ,url-base version @@ -95,8 +105,8 @@ KEY-DOWNLOAD as the OpenPGP key download policy (see 'download-tarball' for details.)" (match (latest-release name) - ((? gnu-release? release) - (let ((version (gnu-release-version release))) + ((? upstream-source? release) + (let ((version (upstream-source-version release))) (match (find-packages (regexp-quote name)) ((info . _) (gnu-package->sexp info release #:key-download key-download)) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index b5574a8d9f..8725ffa0df 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -22,7 +22,8 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-1) #:use-module ((guix download) #:select (download-to-store)) - #:use-module ((guix utils) #:select (package-name->name+version)) + #:use-module ((guix utils) #:select (package-name->name+version + canonical-newline-port)) #:use-module (guix import utils) #:use-module (guix import cabal) #:use-module (guix store) @@ -32,37 +33,35 @@ #:export (hackage->guix-package)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as + ;; List of libraries distributed with ghc (7.10.2). We include GHC itself as ;; some packages list it. - '("ghc" - "haskell98" - "hoopl" + '("array" "base" - "transformers" - "deepseq" - "array" + "bin-package-db" "binary" "bytestring" + "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but + ;; hackage-name->package-name takes this into account. "containers" - "time" - "cabal" - "bin-package-db" + "deepseq" + "directory" + "filepath" + "ghc" "ghc-prim" + "haskeline" + "hoopl" + "hpc" "integer-gmp" - "integer-simple" - "win32" - "template-haskell" + "pretty" "process" - "haskeline" + "rts" + "template-haskell" "terminfo" - "directory" - "filepath" - "old-locale" + "time" + "transformers" "unix" - "old-time" - "pretty" - "xhtml" - "hpc")) + "win32" + "xhtml")) (define package-name-prefix "ghc-") @@ -86,7 +85,8 @@ version." (call-with-temporary-output-file (lambda (temp port) (and (url-fetch url temp) - (call-with-input-file temp read-cabal)))))) + (call-with-input-file temp + (compose read-cabal canonical-newline-port))))))) (define string->license ;; List of valid values from @@ -218,7 +218,7 @@ 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 port) + (read-cabal (canonical-newline-port port)) (hackage-fetch package-name)))) (and=> cabal-meta (compose (cut hackage-module->sexp <> #:include-test-dependencies? diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index d04a68524d..d54bb9fbba 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,23 +26,41 @@ #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (json) #:use-module (web uri) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix import utils) + #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) #:use-module (guix packages) + #:use-module (guix upstream) #:use-module (guix licenses) #:use-module (guix build-system python) + #:use-module (gnu packages) #:use-module (gnu packages python) - #:export (pypi->guix-package)) + #:export (pypi->guix-package + %pypi-updater)) (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, or #f on failure." - (json-fetch (string-append "https://pypi.python.org/pypi/" name "/json"))) + ;; XXX: We want to silence the download progress report, which is especially + ;; annoying for 'guix refresh', but we have to use a file port. + (call-with-output-file "/dev/null" + (lambda (null) + (with-error-to-port null + (lambda () + (json-fetch (string-append "https://pypi.python.org/pypi/" + name "/json"))))))) + +;; For packages found on PyPI that lack a source distribution. +(define-condition-type &missing-source-error &error + missing-source-error? + (package missing-source-error-package)) (define (latest-source-release pypi-package) "Return the latest source release for PYPI-PACKAGE." @@ -49,9 +69,8 @@ or #f on failure." (or (find (lambda (release) (string=? "sdist" (assoc-ref release "packagetype"))) releases) - (error "No source release found for pypi package: " - (assoc-ref* pypi-package "info" "name") - (assoc-ref* pypi-package "info" "version"))))) + (raise (condition (&missing-source-error + (package pypi-package))))))) (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the @@ -60,6 +79,16 @@ package." (snake-case name) (string-append "python-" (snake-case name)))) +(define (guix-package->pypi-name package) + "Given a Python PACKAGE built from pypi.python.org, return the name of the +package on PyPI." + (let ((source-url (and=> (package-source package) origin-uri))) + ;; The URL has the form: + ;; 'https://pypi.python.org/packages/source/' + + ;; first letter of the package name + + ;; '/' + package name + '/' + ... + (substring source-url 42 (string-rindex source-url #\/)))) + (define (maybe-inputs package-inputs) "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a package definition." @@ -165,7 +194,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (version ,version) (source (origin (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) + (uri (pypi-uri ,name version)) (sha256 (base32 ,(guix-hash-url temp))))) @@ -181,12 +210,52 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." `package' s-expression corresponding to that package, or #f on failure." (let ((package (pypi-fetch package-name))) (and package - (let ((name (assoc-ref* package "info" "name")) - (version (assoc-ref* package "info" "version")) - (release (assoc-ref (latest-source-release package) "url")) - (synopsis (assoc-ref* package "info" "summary")) - (description (assoc-ref* package "info" "summary")) - (home-page (assoc-ref* package "info" "home_page")) - (license (string->license (assoc-ref* package "info" "license")))) - (make-pypi-sexp name version release home-page synopsis - description license))))) + (guard (c ((missing-source-error? c) + (let ((package (missing-source-error-package c))) + (leave (_ "no source release for pypi package ~a ~a~%") + (assoc-ref* package "info" "name") + (assoc-ref* package "info" "version"))))) + (let ((name (assoc-ref* package "info" "name")) + (version (assoc-ref* package "info" "version")) + (release (assoc-ref (latest-source-release package) "url")) + (synopsis (assoc-ref* package "info" "summary")) + (description (assoc-ref* package "info" "summary")) + (home-page (assoc-ref* package "info" "home_page")) + (license (string->license (assoc-ref* package "info" "license")))) + (make-pypi-sexp name version release home-page synopsis + description license)))))) + +(define (pypi-package? package) + "Return true if PACKAGE is a Python package from PyPI." + + (define (pypi-url? url) + (string-prefix? "https://pypi.python.org/" url)) + + (let ((source-url (and=> (package-source package) origin-uri)) + (fetch-method (and=> (package-source package) origin-method))) + (and (eq? fetch-method download:url-fetch) + (match source-url + ((? string?) + (pypi-url? source-url)) + ((source-url ...) + (any pypi-url? source-url)))))) + +(define (latest-release guix-package) + "Return an <upstream-source> for the latest release of GUIX-PACKAGE." + (guard (c ((missing-source-error? c) #f)) + (let* ((pypi-name (guix-package->pypi-name + (specification->package guix-package))) + (metadata (pypi-fetch pypi-name)) + (version (assoc-ref* metadata "info" "version")) + (url (assoc-ref (latest-source-release metadata) "url"))) + (upstream-source + (package guix-package) + (version version) + (urls (list url)))))) + +(define %pypi-updater + (upstream-updater + (name 'pypi) + (description "Updater for PyPI packages") + (pred pypi-package?) + (latest latest-release))) |