diff options
| -rw-r--r-- | guix/import/utils.scm | 90 | ||||
| -rw-r--r-- | tests/import-utils.scm | 40 |
2 files changed, 128 insertions, 2 deletions
diff --git a/guix/import/utils.scm b/guix/import/utils.scm index be1980d08f..1e2f0c809d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,9 +26,17 @@ #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix discovery) + #:use-module (guix build-system) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix download) + #:use-module (gnu packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:export (factorize-uri hash-table->alist @@ -45,7 +54,9 @@ license->symbol snake-case - beautify-description)) + beautify-description + + alist->package)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -241,3 +252,80 @@ package definition." (('package ('name (? string? name)) _ ...) `(define-public ,(string->symbol name) ,guix-package)))) + +(define (build-system-modules) + (all-modules (map (lambda (entry) + `(,entry . "guix/build-system")) + %load-path))) + +(define (lookup-build-system-by-name name) + "Return a <build-system> value for the symbol NAME, representing the name of +the build system." + (fold-module-public-variables (lambda (obj result) + (if (and (build-system? obj) + (eq? name (build-system-name obj))) + obj result)) + #f + (build-system-modules))) + +(define (specs->package-lists specs) + "Convert each string in the SPECS list to a list of a package label and a +package value." + (map (lambda (spec) + (let-values (((pkg out) (specification->package+output spec))) + (match out + (("out") (list (package-name pkg) pkg)) + (_ (list (package-name pkg) pkg out))))) + specs)) + +(define (source-spec->object source) + "Generate an <origin> object from a SOURCE specification. The SOURCE can +either be a simple URL string, #F, or an alist containing entries for each of +the expected fields of an <origin> object." + (match source + ((? string? source-url) + (let ((tarball (with-store store (download-to-store store source-url)))) + (origin + (method url-fetch) + (uri source-url) + (sha256 (base32 (guix-hash-url tarball)))))) + (#f #f) + (orig (let ((sha (match (assoc-ref orig "sha256") + ((("base32" . value)) + (base32 value)) + (_ #f)))) + (origin + (method (match (assoc-ref orig "method") + ("url-fetch" (@ (guix download) url-fetch)) + ("git-fetch" (@ (guix git-download) git-fetch)) + ("svn-fetch" (@ (guix svn-download) svn-fetch)) + ("hg-fetch" (@ (guix hg-download) hg-fetch)) + (_ #f))) + (uri (assoc-ref orig "uri")) + (sha256 sha)))))) + +(define (alist->package meta) + (package + (name (assoc-ref meta "name")) + (version (assoc-ref meta "version")) + (source (source-spec->object (assoc-ref meta "source"))) + (build-system + (lookup-build-system-by-name + (string->symbol (assoc-ref meta "build-system")))) + (native-inputs + (specs->package-lists (or (assoc-ref meta "native-inputs") '()))) + (inputs + (specs->package-lists (or (assoc-ref meta "inputs") '()))) + (propagated-inputs + (specs->package-lists (or (assoc-ref meta "propagated-inputs") '()))) + (home-page + (assoc-ref meta "home-page")) + (synopsis + (assoc-ref meta "synopsis")) + (description + (assoc-ref meta "description")) + (license + (let ((l (assoc-ref meta "license"))) + (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) + (spdx-string->license l)) + (license:fsdg-compatible l)))))) diff --git a/tests/import-utils.scm b/tests/import-utils.scm index 8d44b9e0e2..3d8d2c698d 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -21,6 +21,8 @@ #:use-module (guix tests) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix packages) + #:use-module (guix build-system) #:use-module (srfi srfi-64)) (test-begin "import-utils") @@ -38,4 +40,40 @@ 'license:lgpl2.0 (license->symbol license:lgpl2.0)) +(test-assert "alist->package with simple source" + (let* ((meta '(("name" . "hello") + ("version" . "2.10") + ("source" . "mirror://gnu/hello/hello-2.10.tar.gz") + ("build-system" . "gnu") + ("home-page" . "https://gnu.org") + ("synopsis" . "Say hi") + ("description" . "This package says hi.") + ("license" . "GPL-3.0+"))) + (pkg (alist->package meta))) + (and (package? pkg) + (license:license? (package-license pkg)) + (build-system? (package-build-system pkg)) + (origin? (package-source pkg))))) + +(test-assert "alist->package with explicit source" + (let* ((meta '(("name" . "hello") + ("version" . "2.10") + ("source" . (("method" . "url-fetch") + ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz") + ("sha256" . + (("base32" . + "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))) + ("build-system" . "gnu") + ("home-page" . "https://gnu.org") + ("synopsis" . "Say hi") + ("description" . "This package says hi.") + ("license" . "GPL-3.0+"))) + (pkg (alist->package meta))) + (and (package? pkg) + (license:license? (package-license pkg)) + (build-system? (package-build-system pkg)) + (origin? (package-source pkg)) + (equal? (origin-sha256 (package-source pkg)) + (base32 "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))) + (test-end "import-utils") |