nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

import: Add generic data to package converter. 

* guix/import/utils.scm (build-system-modules, lookup-build-system-by-name,
specs->package-lists, source-spec->object, alist->package): New procedures.
* tests/import-utils.scm: Add tests for alist->package.
This commit is contained in:
Ricardo Wurmus 2017-08-27 17:38:47 +02:00
parent 68a91a183b
commit 5e892bc365
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
2 changed files with 128 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
guix/import/utils.scm
View File

@ -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))))))

40
tests/import-utils.scm
View File

@ -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")