02/04: import: Add generic data to package converter.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository guix.

commit 5e892bc365a3da0d30a0982783ee2ab82ee090f8
Author: Ricardo Wurmus <address@hidden>
Date:   Sun Aug 27 17:38:47 2017 +0200

    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.
---
 guix/import/utils.scm  | 90 +++++++++++++++++++++++++++++++++++++++++++++++++-
 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 be1980d..1e2f0c8 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016 Jelle Licht <address@hidden>
 ;;; Copyright © 2016 David Craven <address@hidden>
+;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; 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 8d44b9e..3d8d2c6 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 <address@hidden>
+;;; Copyright © 2015, 2017 Ricardo Wurmus <address@hidden>
 ;;; Copyright © 2016 Ben Woodcroft <address@hidden>
 ;;;
 ;;; 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")