summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/import/utils.scm90
-rw-r--r--tests/import-utils.scm40
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")