From 0b131612d5f0387eb68da4ac49a384c57ca78851 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Apr 2015 10:20:25 +0200 Subject: tests: Skip 'guix-package-net.sh' when prerequisites aren't met. * tests/guix-package-net.sh: Reinstate networking and shebang test that inadvertently vanished in commit 57b8623. --- tests/guix-package-net.sh | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'tests') diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index cedfa3217b..cf3233bee2 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -37,6 +37,14 @@ shebang_too_long () -ge 128 } +if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null \ + || shebang_too_long +then + # Skipping. + exit 77 +fi + + profile="t-profile-$$" rm -f "$profile" -- cgit v1.2.3 From b29455cfe7440e08f485eabc7a9335a856cacab8 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sun, 8 Mar 2015 07:48:38 +0100 Subject: import: Add hackage importer. * guix/import/hackage.scm: New file. * tests/hackage.scm: New file. --- guix/import/hackage.scm | 767 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/hackage.scm | 134 +++++++++ 2 files changed, 901 insertions(+) create mode 100644 guix/import/hackage.scm create mode 100644 tests/hackage.scm (limited to 'tests') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm new file mode 100644 index 0000000000..1b27803dba --- /dev/null +++ b/guix/import/hackage.scm @@ -0,0 +1,767 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa +;;; +;;; 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 hackage) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #: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 import utils) + #:use-module (guix store) + #:use-module (guix hash) + #:use-module (guix base32) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) + #:export (hackage->guix-package)) + +;; Part 1: +;; +;; Functions used to read a Cabal file. + +(define ghc-standard-libraries + ;; List of libraries distributed with ghc (7.8.4). We include GHC itself as + ;; some packages list it. + '("ghc" + "haskell98" + "hoopl" + "base" + "transformers" + "deepseq" + "array" + "binary" + "bytestring" + "containers" + "time" + "cabal" + "bin-package-db" + "ghc-prim" + "integer-gmp" + "integer-simple" + "win32" + "template-haskell" + "process" + "haskeline" + "terminfo" + "directory" + "filepath" + "old-locale" + "unix" + "old-time" + "pretty" + "xhtml" + "hpc")) + +(define package-name-prefix "ghc-") + +(define key-value-rx + ;; Regular expression matching "key: value" + (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$")) + +(define sections-rx + ;; Regular expression matching a section "head sub-head ..." + (make-regexp "([a-zA-Z0-9\\(\\)-]+)")) + +(define comment-rx + ;; Regexp matching Cabal comment lines. + (make-regexp "^ *--")) + +(define (has-key? line) + "Check if LINE includes a key." + (regexp-exec key-value-rx line)) + +(define (comment-line? line) + "Check if LINE is a comment line." + (regexp-exec comment-rx line)) + +(define (line-indentation+rest line) + "Returns two results: The number of indentation spaces and the rest of the +line (without indentation)." + (let loop ((line-lst (string->list line)) + (count 0)) + ;; Sometimes values are spread over multiple lines and new lines start + ;; with a comma ',' with the wrong indentation. See e.g. haddock-api. + (if (or (null? line-lst) + (not (or + (eqv? (first line-lst) #\space) + (eqv? (first line-lst) #\,) ; see, e.g., haddock-api.cabal + (eqv? (first line-lst) #\tab)))) + (values count (list->string line-lst)) + (loop (cdr line-lst) (+ count 1))))) + +(define (multi-line-value lines seed) + "Function to read a value split across multiple lines. LINES are the +remaining input lines to be read. SEED is the value read on the same line as +the key. Return two values: A list with values and the remaining lines to be +processed." + (define (multi-line-value-with-min-indent lines seed min-indent) + (if (null? lines) + (values '() '()) + (let-values (((current-indent value) (line-indentation+rest (first lines))) + ((next-line-indent next-line-value) + (if (null? (cdr lines)) + (values #f "") + (line-indentation+rest (second lines))))) + (if (or (not next-line-indent) (< next-line-indent min-indent) + (regexp-exec condition-rx next-line-value)) + (values (reverse (cons value seed)) (cdr lines)) + (multi-line-value-with-min-indent (cdr lines) (cons value seed) + min-indent))))) + + (let-values (((current-indent value) (line-indentation+rest (first lines)))) + (multi-line-value-with-min-indent lines seed current-indent))) + +(define (read-cabal port) + "Parses a Cabal file from PORT. Return a list of list pairs: + +(((head1 sub-head1 ... key1) (value)) + ((head2 sub-head2 ... key2) (value2)) + ...). + +We try do deduce the Cabal format from the following document: +https://www.haskell.org/cabal/users-guide/developing-packages.html + +Keys are case-insensitive. We therefore lowercase them. Values are +case-sensitive. Currently only indentation-structured files are parsed. +Braces structured files are not handled." ;" <- make emacs happy. + (define (read-and-trim-line port) + (let ((line (read-line port))) + (if (string? line) + (string-trim-both line #\return) + line))) + + (define (strip-insignificant-lines port) + (let loop ((line (read-and-trim-line port)) + (result '())) + (cond + ((eof-object? line) + (reverse result)) + ((or (string-null? line) (comment-line? line)) + (loop (read-and-trim-line port) result)) + (else + (loop (read-and-trim-line port) (cons line result)))))) + + (let loop + ((lines (strip-insignificant-lines port)) + (indents '()) ; only includes indents at start of section heads. + (sections '()) + (result '())) + (let-values + (((current-indent line) + (if (null? lines) + (values 0 "") + (line-indentation+rest (first lines)))) + ((next-line-indent next-line) + (if (or (null? lines) (null? (cdr lines))) + (values 0 "") + (line-indentation+rest (second lines))))) + (if (null? lines) + (reverse result) + (let ((rx-result (has-key? line))) + (cond + (rx-result + (let ((key (string-downcase (match:substring rx-result 1))) + (value (match:substring rx-result 2))) + (cond + ;; Simple single line "key: value". + ((= next-line-indent current-indent) + (loop (cdr lines) indents sections + (cons + (list (reverse (cons key sections)) (list value)) + result))) + ;; Multi line "key: value\n value cont...". + ((> next-line-indent current-indent) + (let*-values (((value-lst lines) + (multi-line-value (cdr lines) + (if (string-null? value) + '() + `(,value))))) + ;; multi-line-value returns to the first line after the + ;; multi-value. + (loop lines indents sections + (cons + (list (reverse (cons key sections)) value-lst) + result)))) + ;; Section ended. + (else + ;; Indentation is reduced. Check by how many levels. + (let* ((idx (and=> (list-index + (lambda (x) (= next-line-indent x)) + indents) + (cut + <> + (if (has-key? next-line) 1 0)))) + (sec + (if idx + (drop sections idx) + (raise + (condition + (&message + (message "unable to parse Cabal file")))))) + (ind (drop indents idx))) + (loop (cdr lines) ind sec + (cons + (list (reverse (cons key sections)) (list value)) + result))))))) + ;; Start of a new section. + ((or (null? indents) + (> current-indent (first indents))) + (loop (cdr lines) (cons current-indent indents) + (cons (string-downcase line) sections) result)) + (else + (loop (cdr lines) indents + (cons (string-downcase line) (cdr sections)) + result)))))))) + +(define condition-rx + ;; Regexp for conditionals. + (make-regexp "^if +(.*)$")) + +(define (split-section section) + "Split SECTION in individual words with exception for the predicate of an +'if' conditional." + (let ((rx-result (regexp-exec condition-rx section))) + (if rx-result + `("if" ,(match:substring rx-result 1)) + (map match:substring (list-matches sections-rx section))))) + +(define (join-sections sec1 sec2) + (fold-right cons sec2 sec1)) + +(define (pre-process-keys key) + (match key + (() '()) + ((sec1 rest ...) + (join-sections (split-section sec1) (pre-process-keys rest))))) + +(define (pre-process-entry-keys entry) + (match entry + ((key value) + (list (pre-process-keys key) value)) + (() '()))) + +(define (pre-process-entries-keys entries) + "ENTRIES is a list of list pairs, a keys list and a valules list, as +produced by 'read-cabal'. Split each element of the keys list into individual +words. This pre-processing is used to read flags." + (match entries + ((entry rest ...) + (cons (pre-process-entry-keys entry) + (pre-process-entries-keys rest))) + (() + '()))) + +(define (get-flags pre-processed-entries) + "PRE-PROCESSED-ENTRIES is a list of list pairs, a keys list and a values +list, as produced by 'read-cabal' and pre-processed by +'pre-process-entries-keys'. Return a list of pairs with the name of flags and +their default value (one of \"False\" or \"True\") as specified in the Cabal file: + +((\"flag1-name\" . \"False-or-True\") ...)." ;" <- make emacs happy + (match pre-processed-entries + (() '()) + (((("flag" flag-name "default") (flag-val)) rest ...) + (cons (cons flag-name flag-val) + (get-flags rest))) + ((entry rest ... ) + (get-flags rest)) + (_ #f))) + +;; Part 2: +;; +;; Functions to read information from the Cabal object created by 'read-cabal' +;; and convert Cabal format dependencies conditionals into equivalent +;; S-expressions. + +(define tests-rx + ;; Cabal test keywords + (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)")) + +(define parens-rx + ;; Parentheses within conditions + (make-regexp "\\((.+)\\)")) + +(define or-rx + ;; OR operator in conditions + (make-regexp " +\\|\\| +")) + +(define and-rx + ;; AND operator in conditions + (make-regexp " +&& +")) + +(define not-rx + ;; NOT operator in conditions + (make-regexp "^!.+")) + +(define (bi-op-args str match-lst) + "Return a list with the arguments of (logic) bianry operators. MATCH-LST +is the result of 'list-match' against a binary operator regexp on STR." + (let ((operators (length match-lst))) + (map (lambda (from to) + (substring str from to)) + (cons 0 (map match:end match-lst)) + (append (map match:start match-lst) (list (string-length str)))))) + +(define (bi-op->sexp-like bi-op args) + "BI-OP is a string with the name of a Scheme operator which in a Cabal file +is represented by a binary operator. ARGS are the arguments of said operator. +Return a string representing an S-expression of the operator applied to its +arguments." + (if (= (length args) 1) + (first args) + (string-append "(" bi-op + (fold (lambda (arg seed) (string-append seed " " arg)) + "" args) ")"))) + +(define (not->sexp-like arg) + "If the string ARG is prefixed by a Cabal negation operator, convert it to +an equivalent Scheme S-expression string." + (if (regexp-exec not-rx arg) + (string-append "(not " + (substring arg 1 (string-length arg)) + ")") + arg)) + +(define (parens-less-cond->sexp-like conditional) + "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme +syntax. This procedure accepts only simple conditionals without parentheses." + ;; The outher operation is the one with the lowest priority: OR + (bi-op->sexp-like + "or" + ;; each OR argument may be an AND operation + (map (lambda (or-arg) + (let ((m-lst (list-matches and-rx or-arg))) + ;; is there an AND operation? + (if (> (length m-lst) 0) + (bi-op->sexp-like + "and" + ;; expand NOT operators when there are ANDs + (map not->sexp-like (bi-op-args or-arg m-lst))) + ;; ... and when there aren't. + (not->sexp-like or-arg)))) + ;; list of OR arguments + (bi-op-args conditional (list-matches or-rx conditional))))) + +(define test-keyword-ornament "__") + +(define (conditional->sexp-like conditional) + "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme +syntax." + ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests + ;; keywords so that parentheses are only used to set precedences. This + ;; substantially simplify parsing. + (let ((conditional + (regexp-substitute/global #f tests-rx conditional + 'pre 1 test-keyword-ornament 2 + test-keyword-ornament 'post))) + (let loop ((sub-cond conditional)) + (let ((rx-result (regexp-exec parens-rx sub-cond))) + (cond + (rx-result + (parens-less-cond->sexp-like + (string-append + (match:prefix rx-result) + (loop (match:substring rx-result 1)) + (match:suffix rx-result)))) + (else + (parens-less-cond->sexp-like sub-cond))))))) + +(define (eval-flags sexp-like-cond flags) + "SEXP-LIKE-COND is a string representing an S-expression conditional. FLAGS +is a list of flag name and value pairs as produced by 'get-flags'. Substitute +\"#t\" or \"#f\" according to the value of flags. (Default to \"True\")." + (fold-right + (lambda (flag sexp) + (match flag + ((name . value) + (let ((rx (make-regexp + (string-append "flag" test-keyword-ornament name + test-keyword-ornament)))) + (regexp-substitute/global + #f rx sexp + 'pre (if (string-ci= value "False") "#f" "#t") 'post))) + (_ sexp))) + sexp-like-cond + (cons '("[a-zA-Z0-9_-]+" . "True") flags))) + +(define (eval-tests->sexp sexp-like-cond) + "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and +\"arch(...)\" with equivalent Scheme checks. Retrun an S-expression." + (with-input-from-string + (fold-right + (lambda (test sexp) + (match test + ((type pre-match post-match) + (let ((rx (make-regexp + (string-append type test-keyword-ornament "(\\w+)" + test-keyword-ornament)))) + (regexp-substitute/global + #f rx sexp + 'pre pre-match 2 post-match 'post))) + (_ sexp))) + sexp-like-cond + ;; (%current-system) returns, e.g., "x86_64-linux" or "i686-linux". + '(("(os|arch)" "(string-match \"" "\" (%current-system))"))) + read)) + +(define (eval-impl sexp-like-cond) + "Check for the Cabal test \"impl(...)\" in the string SEXP-LIKE-COND. +Assume the module declaring the generated package includes a local variable +called \"haskell-implementation\" with a string value of the form NAME-VERSION +against which we compare." + (with-output-to-string + (lambda () + (write + (with-input-from-string + (fold-right + (lambda (test sexp) + (match test + ((pre-match post-match) + (let ((rx-with-version + (make-regexp + (string-append + "impl" test-keyword-ornament + "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" + test-keyword-ornament))) + (rx-without-version + (make-regexp + (string-append "impl" test-keyword-ornament "(\\w+)" + test-keyword-ornament)))) + (if (regexp-exec rx-with-version sexp) + (regexp-substitute/global + #f rx-with-version sexp + 'pre pre-match 2 " " post-match " \"" 1 "-" 3 "\")" 'post) + (regexp-substitute/global + #f rx-without-version sexp + 'pre pre-match "-match \"" 1 "\" " post-match ")" 'post)))) + (_ sexp))) + sexp-like-cond + '(("(string" "haskell-implementation"))) + read))))) + +(define (eval-cabal-keywords sexp-like-cond flags) + ((compose eval-tests->sexp eval-impl (cut eval-flags <> flags)) + sexp-like-cond)) + +(define (key->values meta key) + "META is the representation of a Cabal file as produced by 'read-cabal'. +Return the list of values associated with a specific KEY (a string)." + (match meta + (() '()) + (((((? (lambda(x) (equal? x key)))) v) r ...) + v) + (((k v) r ...) + (key->values (cdr meta) key)) + (_ "key Not fount"))) + +(define (key-start-end->entries meta key-start-rx key-end-rx) + "META is the representation of a Cabal file as produced by 'read-cabal'. +Return all entries whose keys list starts with KEY-START and ends with +KEY-END." + (let ((pred + (lambda (x) + (and (regexp-exec key-start-rx (first x)) + (regexp-exec key-end-rx (last x)))))) + ;; (equal? (list key-start key-end) (list (first x) (last x)))))) + (match meta + (() '()) + ((((? pred k) v) r ...) + (cons `(,k ,v) + (key-start-end->entries (cdr meta) key-start-rx key-end-rx))) + (((k v) r ...) + (key-start-end->entries (cdr meta) key-start-rx key-end-rx)) + (_ "key Not fount")))) + +(define else-rx + (make-regexp "^else$")) + +(define (count-if-else rx-result-ls) + (apply + (map (lambda (m) (if m 1 0)) rx-result-ls))) + +(define (analyze-entry-cond entry) + (let* ((keys (first entry)) + (vals (second entry)) + (rx-cond-result + (map (cut regexp-exec condition-rx <>) keys)) + (rx-else-result + (map (cut regexp-exec else-rx <>) keys)) + (cond-no (count-if-else rx-cond-result)) + (else-no (count-if-else rx-else-result)) + (cond-idx (list-index (lambda (rx) (if rx #t #f)) rx-cond-result)) + (else-idx (list-index (lambda (rx) (if rx #t #f)) rx-else-result)) + (key-cond + (cond + ((or (and cond-idx else-idx (< cond-idx else-idx)) + (and cond-idx (not else-idx))) + (match:substring + (receive (head tail) + (split-at rx-cond-result cond-idx) (first tail)))) + ((or (and cond-idx else-idx (> cond-idx else-idx)) + (and (not cond-idx) else-idx)) + (match:substring + (receive (head tail) + (split-at rx-else-result else-idx) (first tail)))) + (else + "")))) + (values keys vals rx-cond-result + rx-else-result cond-no else-no key-cond))) + +(define (remove-cond entry cond) + (match entry + ((k v) + (list (cdr (member cond k)) v)))) + +(define (group-and-reduce-level entries group group-cond) + (let loop + ((true-group group) + (false-group '()) + (entries entries)) + (if (null? entries) + (values (reverse true-group) (reverse false-group) entries) + (let*-values (((entry) (first entries)) + ((keys vals rx-cond-result rx-else-result + cond-no else-no key-cond) + (analyze-entry-cond entry))) + (cond + ((and (>= (+ cond-no else-no) 1) (string= group-cond key-cond)) + (loop (cons (remove-cond entry group-cond) true-group) false-group + (cdr entries))) + ((and (>= (+ cond-no else-no) 1) (string= key-cond "else")) + (loop true-group (cons (remove-cond entry "else") false-group) + (cdr entries))) + (else + (values (reverse true-group) (reverse false-group) entries))))))) + +(define dependencies-rx + (make-regexp "([a-zA-Z0-9_-]+) *[^,]*,?")) + +(define (hackage-name->package-name name) + (if (string-prefix? package-name-prefix name) + (string-downcase name) + (string-append package-name-prefix (string-downcase name)))) + +(define (split-and-filter-dependencies ls names-to-filter) + "Split the comma separated list of dependencies LS coming from the Cabal +file, filter packages included in NAMES-TO-FILTER and return a list with +inputs suitable for the Guix package. Currently the version information is +discarded." + (define (split-at-comma-and-filter d) + (fold + (lambda (m seed) + (let* ((name (string-downcase (match:substring m 1))) + (pkg-name (hackage-name->package-name name))) + (if (member name names-to-filter) + seed + (cons (list pkg-name (list 'unquote (string->symbol pkg-name))) + seed)))) + '() + (list-matches dependencies-rx d))) + + (fold (lambda (d p) (append (split-at-comma-and-filter d) p)) '() ls)) + +(define* (dependencies-cond->sexp meta #:key (include-test-dependencies? #t)) + "META is the representation of a Cabal file as produced by 'read-cabal'. +Return an S-expression containing the list of dependencies as expected by the +'inputs' field of a package. The generated S-expressions may include +conditionals as defined in the cabal file. During this process we discard the +version information of the packages." + (define (take-dependencies meta) + (let ((key-start-exe (make-regexp "executable")) + (key-start-lib (make-regexp "library")) + (key-start-tests (make-regexp "test-suite")) + (key-end (make-regexp "build-depends"))) + (append + (key-start-end->entries meta key-start-exe key-end) + (key-start-end->entries meta key-start-lib key-end) + (if include-test-dependencies? + (key-start-end->entries meta key-start-tests key-end) + '())))) + + (let ((flags (get-flags (pre-process-entries-keys meta))) + (augmented-ghc-std-libs (append (key->values meta "name") + ghc-standard-libraries))) + (delete-duplicates + (let loop ((entries (take-dependencies meta)) + (result '())) + (if (null? entries) + (reverse result) + (let*-values (((entry) (first entries)) + ((keys vals rx-cond-result rx-else-result + cond-no else-no key-cond) + (analyze-entry-cond entry))) + (cond + ((= (+ cond-no else-no) 0) + (loop (cdr entries) + (append + (split-and-filter-dependencies vals + augmented-ghc-std-libs) + result))) + (else + (let-values (((true-group false-group entries) + (group-and-reduce-level entries '() + key-cond)) + ((cond-final) (eval-cabal-keywords + (conditional->sexp-like + (last (split-section key-cond))) + flags))) + (loop entries + (cond + ((or (eq? cond-final #t) (equal? cond-final '(not #f))) + (append (loop true-group '()) result)) + ((or (eq? cond-final #f) (equal? cond-final '(not #t))) + (append (loop false-group '()) result)) + (else + (let ((true-group-result (loop true-group '())) + (false-group-result (loop false-group '()))) + (cond + ((and (null? true-group-result) + (null? false-group-result)) + result) + ((null? false-group-result) + (cons `(unquote-splicing + (when ,cond-final ,true-group-result)) + result)) + ((null? true-group-result) + (cons `(unquote-splicing + (unless ,cond-final ,false-group-result)) + result)) + (else + (cons `(unquote-splicing + (if ,cond-final + ,true-group-result + ,false-group-result)) + result)))))))))))))))) + +;; Part 3: +;; +;; Retrive the desired package and its Cabal file from +;; http://hackage.haskell.org and construct the Guix package S-expression. + +(define (hackage-fetch name-version) + "Return the Cabal file for the package NAME-VERSION, or #f on failure. If +the version part is omitted from the package name, then return the latest +version." + (let*-values (((name version) (package-name->name+version name-version)) + ((url) + (if version + (string-append "http://hackage.haskell.org/package/" + name "-" version "/" name ".cabal") + (string-append "http://hackage.haskell.org/package/" + name "/" name ".cabal")))) + (call-with-temporary-output-file + (lambda (temp port) + (and (url-fetch url temp) + (call-with-input-file temp read-cabal)))))) + +(define string->license + ;; List of valid values from + ;; https://www.haskell.org + ;; /cabal/release/cabal-latest/doc/API/Cabal/Distribution-License.html. + (match-lambda + ("GPL-2" 'gpl2) + ("GPL-3" 'gpl3) + ("GPL" "'gpl??") + ("AGPL-3" 'agpl3) + ("AGPL" "'agpl??") + ("LGPL-2.1" 'lgpl2.1) + ("LGPL-3" 'lgpl3) + ("LGPL" "'lgpl??") + ("BSD2" 'bsd-2) + ("BSD3" 'bsd-3) + ("MIT" 'expat) + ("ISC" 'isc) + ("MPL" 'mpl2.0) + ("Apache-2.0" 'asl2.0) + ((x) (string->license x)) + ((lst ...) `(list ,@(map string->license lst))) + (_ #f))) + +(define* (hackage-module->sexp meta #:key (include-test-dependencies? #t)) + "Return the `package' S-expression for a Cabal package. META is the +representation of a Cabal file as produced by 'read-cabal'." + + (define name + (first (key->values meta "name"))) + + (define version + (first (key->values meta "version"))) + + (define description + (let*-values (((description) (key->values meta "description")) + ((lines last) + (split-at description (- (length description) 1)))) + (fold-right (lambda (line seed) (string-append line "\n" seed)) + (first last) lines))) + + (define source-url + (string-append "http://hackage.haskell.org/package/" name + "/" name "-" version ".tar.gz")) + + ;; Several packages do not have an official home-page other than on Hackage. + (define home-page + (let ((home-page-entry (key->values meta "homepage"))) + (if (null? home-page-entry) + (string-append "http://hackage.haskell.org/package/" name) + (first home-page-entry)))) + + (define (maybe-inputs input-type inputs) + (match inputs + (() + '()) + ((inputs ...) + (list (list input-type + (list 'quasiquote inputs)))))) + + (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-cond->sexp meta + #:include-test-dependencies? + include-test-dependencies?)) + (home-page ,home-page) + (synopsis ,@(key->values meta "synopsis")) + (description ,description) + (license ,(string->license (key->values meta "license")))))) + +(define* (hackage->guix-package module-name + #:key (include-test-dependencies? #t)) + "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, and return +the `package' S-expression corresponding to that package, or #f on failure." + (let ((module-meta (hackage-fetch module-name))) + (and=> module-meta (cut hackage-module->sexp <> + #:include-test-dependencies? + include-test-dependencies?)))) + +;;; cabal.scm ends here diff --git a/tests/hackage.scm b/tests/hackage.scm new file mode 100644 index 0000000000..23b854caa4 --- /dev/null +++ b/tests/hackage.scm @@ -0,0 +1,134 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Federico Beffa +;;; +;;; 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-hackage) + #:use-module (guix import hackage) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(define test-cabal-1 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +executable cabal + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +;; Use TABs to indent lines and to separate keys from value. +(define test-cabal-2 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +executable cabal + build-depends: HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +;; Use indentation with comma as found, e.g., in 'haddock-api'. +(define test-cabal-3 + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +executable cabal + build-depends: + HTTP >= 4000.2.5 && < 4000.3 + , mtl >= 2.0 && < 3 +") + +(define test-cond-1 + "(os(darwin) || !(flag(debug))) && flag(cips)") + +(define read-cabal + (@@ (guix import hackage) read-cabal)) + +(define eval-cabal-keywords + (@@ (guix import hackage) eval-cabal-keywords)) + +(define conditional->sexp-like + (@@ (guix import hackage) conditional->sexp-like)) + +(test-begin "hackage") + +(define (eval-test-with-cabal test-cabal) + (mock + ((guix import hackage) hackage-fetch + (lambda (name-version) + (call-with-input-string test-cabal + read-cabal))) + (match (hackage->guix-package "foo") + (('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "http://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-http" ('unquote 'ghc-http)) + ("ghc-mtl" ('unquote 'ghc-mtl))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'bsd-3)) + #t) + (x + (pk 'fail x #f))))) + +(test-assert "hackage->guix-package test 1" + (eval-test-with-cabal test-cabal-1)) + +(test-assert "hackage->guix-package test 2" + (eval-test-with-cabal test-cabal-2)) + +(test-assert "hackage->guix-package test 3" + (eval-test-with-cabal test-cabal-3)) + +(test-assert "conditional->sexp-like" + (match + (eval-cabal-keywords + (conditional->sexp-like test-cond-1) + '(("debug" . "False"))) + (('and ('or ('string-match "darwin" ('%current-system)) ('not '#f)) '#t) + #t) + (x + (pk 'fail x #f)))) + +(test-end "hackage") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From 042bc828fcd2dc7bbacbe6ef0408722a3d51a684 Mon Sep 17 00:00:00 2001 From: Federico Beffa Date: Sat, 4 Apr 2015 22:51:13 +0200 Subject: profiles: Generate GHC's package database cache. * guix/profiles.scm (ghc-package-cache-file): New procedure. (profile-derivation): Add 'ghc-package-cache?' keyword argument. If true (the default), add the result of 'ghc-package-cache-file' to 'inputs'. * guix/scripts/package.scm (guix-package)[process-actions]: Pass #:ghc-package-cache? to 'profile-generation'. * tests/packages.scm ("--search-paths with pattern"): Likewise. * tests/profiles.scm ("profile-derivation"): Likewise. --- guix/profiles.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++++-- guix/scripts/package.scm | 1 + tests/packages.scm | 1 + tests/profiles.scm | 2 ++ 4 files changed, 62 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/profiles.scm b/guix/profiles.scm index 465aaf9477..a2f63d1cca 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -404,6 +404,55 @@ (define (install-info info) (gexp->derivation "info-dir" build #:modules '((guix build utils))))) +(define (ghc-package-cache-file manifest) + "Return a derivation that builds the GHC 'package.cache' file for all the +entries of MANIFEST." + (define ghc ;lazy reference + (module-ref (resolve-interface '(gnu packages haskell)) 'ghc)) + + (define build + #~(begin + (use-modules (guix build utils) + (srfi srfi-1) (srfi srfi-26) + (ice-9 ftw)) + + (define ghc-name-version + (let* ((base (basename #+ghc))) + (string-drop base + (+ 1 (string-index base #\-))))) + + (define db-subdir + (string-append "lib/" ghc-name-version "/package.conf.d")) + + (define db-dir + (string-append #$output "/" db-subdir)) + + (define (conf-files top) + (find-files (string-append top "/" db-subdir) "\\.conf$")) + + (define (copy-conf-file conf) + (let ((base (basename conf))) + (copy-file conf (string-append db-dir "/" base)))) + + (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir) + (for-each copy-conf-file + (append-map conf-files + '#$(manifest-inputs manifest))) + (let ((success + (zero? + (system* (string-append #+ghc "/bin/ghc-pkg") "recache" + (string-append "--package-db=" db-dir))))) + (for-each delete-file (find-files db-dir "\\.conf$")) + success))) + + ;; Don't depend on GHC when there's nothing to do. + (if (any (cut string-prefix? "ghc" <>) + (map manifest-entry-name (manifest-entries manifest))) + (gexp->derivation "ghc-package-cache" build + #:modules '((guix build utils)) + #:local-build? #t) + (gexp->derivation "ghc-package-cache" #~(mkdir #$output)))) + (define (ca-certificate-bundle manifest) "Return a derivation that builds a single-file bundle containing the CA certificates in the /etc/ssl/certs sub-directories of the packages in @@ -465,14 +514,18 @@ (define (dump file port) (define* (profile-derivation manifest #:key (info-dir? #t) + (ghc-package-cache? #t) (ca-certificate-bundle? #t)) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes a top-level Info 'dir' file unless -INFO-DIR? is #f, and a single-file CA certificate bundle unless -CA-CERTIFICATE-BUNDLE? is #f." +INFO-DIR? is #f, a GHC 'package.cache' file unless GHC-PACKAGE-CACHE? is #f +and a single-file CA certificate bundle unless CA-CERTIFICATE-BUNDLE? is #f." (mlet %store-monad ((info-dir (if info-dir? (info-dir-file manifest) (return #f))) + (ghc-package-cache (if ghc-package-cache? + (ghc-package-cache-file manifest) + (return #f))) (ca-cert-bundle (if ca-certificate-bundle? (ca-certificate-bundle manifest) (return #f)))) @@ -480,6 +533,9 @@ (define inputs (append (if info-dir (list (gexp-input info-dir)) '()) + (if ghc-package-cache + (list (gexp-input ghc-package-cache)) + '()) (if ca-cert-bundle (list (gexp-input ca-cert-bundle)) '()) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 6190f3286d..09ae782751 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -838,6 +838,7 @@ (define profile (assoc-ref opts 'profile)) (profile-derivation new #:info-dir? (not bootstrap?) + #:ghc-package-cache? (not bootstrap?) #:ca-certificate-bundle? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-manifest-transaction (%store) manifest transaction diff --git a/tests/packages.scm b/tests/packages.scm index c9dd5d859a..4e3a116cb8 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -600,6 +600,7 @@ (define read-at (manifest (map package->manifest-entry (list p1 p2))) #:info-dir? #f + #:ghc-package-cache? #f #:ca-certificate-bundle? #f) #:guile-for-build (%guile-for-build)))) (build-derivations %store (list prof)) diff --git a/tests/profiles.scm b/tests/profiles.scm index 7b942e35b0..d20cb9d808 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -184,6 +184,7 @@ (define glibc (guile (package->derivation %bootstrap-guile)) (drv (profile-derivation (manifest (list entry)) #:info-dir? #f + #:ghc-package-cache? #f #:ca-certificate-bundle? #f)) (profile -> (derivation->output-path drv)) (bindir -> (string-append profile "/bin")) @@ -197,6 +198,7 @@ (define glibc ((entry -> (package->manifest-entry packages:glibc "debug")) (drv (profile-derivation (manifest (list entry)) #:info-dir? #f + #:ghc-package-cache? #f #:ca-certificate-bundle? #f))) (return (derivation-inputs drv)))) -- cgit v1.2.3