Merge branch 'master' into core-updates

1 files changed, 60 insertions, 1 deletions

diff --git a/guix/import/json.scm b/guix/import/json.scm
index 8900724dcd..0c98bb25b8 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -22,8 +23,16 @@
   #:use-module (json)
   #:use-module (guix http-client)
   #:use-module (guix import utils)
+  #:use-module (guix import print)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
-  #:export (json-fetch))
+  #:export (json-fetch
+            json->code
+            json->scheme-file))
 
 (define* (json-fetch url
                      ;; Note: many websites returns 403 if we omit a
@@ -42,3 +51,53 @@ the query."
            (result (json->scm port)))
       (close-port port)
       result)))
+
+(define (json->code file-name)
+  "Read FILE-NAME containing one ore more JSON package definitions and return
+a list of S-expressions, or return #F when the JSON is invalid."
+  (catch 'json-invalid
+    (lambda ()
+      (let ((json (json-string->scm
+                   (with-input-from-file file-name read-string))))
+        (match json
+          (#(packages ...)
+           ;; To allow definitions to refer to one another, collect references
+           ;; to local definitions and tell alist->package to ignore them.
+           (second
+            (memq #:result
+                  (fold
+                   (lambda (pkg names+result)
+                     (match names+result
+                       ((#:names names #:result result)
+                        (list #:names
+                              (cons (assoc-ref pkg "name") names)
+                              #:result
+                              (append result
+                                      (list
+                                       (package->code (alist->package pkg names))
+                                       (string->symbol (assoc-ref pkg "name"))))))))
+                        (list #:names '()
+                              #:result '())
+                        packages))))
+          (package
+            (list (package->code (alist->package json))
+                  (string->symbol (assoc-ref json "name")))))))
+    (const #f)))
+
+(define (json->scheme-file file)
+  "Convert the FILE containing a JSON package definition to a Scheme
+representation and return the new file name (or #F on error)."
+  (and-let* ((sexprs (json->code file))
+             (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp"))
+                           (template (string-append tempdir "/guix-XXXXXX"))
+                           (port     (mkstemp! template)))
+                      (close-port port)
+                      template)))
+    (call-with-output-file file*
+      (lambda (port)
+        (write '(use-modules (gnu)
+                             (guix)
+                             ((guix licenses) #:prefix license:))
+               port)
+        (for-each (cut write <> port) sexprs)))
+    file*))