diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/json.scm | 61 | ||||
| -rw-r--r-- | guix/import/print.scm | 96 | ||||
| -rw-r--r-- | guix/import/utils.scm | 36 |
3 files changed, 136 insertions, 57 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*)) diff --git a/guix/import/print.scm b/guix/import/print.scm index 4c2a91fa4f..11cc218285 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,7 @@ when evaluated." ;; Print either license variable name or the code for a license object (define (license->code lic) (let ((var (variable-name lic '(guix licenses)))) - (or var + (or (symbol-append 'license: var) `(license (name ,(license-name lic)) (uri ,(license-uri lic)) @@ -79,7 +79,9 @@ when evaluated." (patches (origin-patches source))) `(origin (method ,(procedure-name method)) - (uri (string-append ,@(factorize-uri uri version))) + (uri (string-append ,@(match (factorize-uri uri version) + ((? string? uri) (list uri)) + (factorized factorized)))) (sha256 (base32 ,(format #f "~a" (bytevector->nix-base32-string sha256)))) @@ -92,6 +94,8 @@ when evaluated." (define (package-lists->code lsts) (list 'quasiquote (map (match-lambda + ((? symbol? s) + (list (symbol->string s) (list 'unquote s))) ((label pkg . out) (let ((mod (package-module-name pkg))) (cons* label @@ -121,45 +125,47 @@ when evaluated." (home-page (package-home-page package)) (supported-systems (package-supported-systems package)) (properties (package-properties package))) - `(package - (name ,name) - (version ,version) - (source ,(source->code source version)) - ,@(match properties - (() '()) - (_ `((properties ,properties)))) - ,@(if replacement - `((replacement ,replacement)) - '()) - (build-system ,(symbol-append (build-system-name build-system) - '-build-system)) - ,@(match arguments - (() '()) - (args `((arguments ,(list 'quasiquote args))))) - ,@(match outputs - (("out") '()) - (outs `((outputs (list ,@outs))))) - ,@(match native-inputs - (() '()) - (pkgs `((native-inputs ,(package-lists->code pkgs))))) - ,@(match inputs - (() '()) - (pkgs `((inputs ,(package-lists->code pkgs))))) - ,@(match propagated-inputs - (() '()) - (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) - ,@(if (lset= string=? supported-systems %supported-systems) - '() - `((supported-systems (list ,@supported-systems)))) - ,@(match (map search-path-specification->code native-search-paths) - (() '()) - (paths `((native-search-paths (list ,@paths))))) - ,@(match (map search-path-specification->code search-paths) - (() '()) - (paths `((search-paths (list ,@paths))))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,description) - (license ,(if (list? license) - `(list ,@(map license->code license)) - (license->code license)))))) + `(define-public ,(string->symbol name) + (package + (name ,name) + (version ,version) + (source ,(source->code source version)) + ,@(match properties + (() '()) + (_ `((properties ,properties)))) + ,@(if replacement + `((replacement ,replacement)) + '()) + (build-system (@ (guix build-system ,(build-system-name build-system)) + ,(symbol-append (build-system-name build-system) + '-build-system))) + ,@(match arguments + (() '()) + (args `((arguments ,(list 'quasiquote args))))) + ,@(match outputs + (("out") '()) + (outs `((outputs (list ,@outs))))) + ,@(match native-inputs + (() '()) + (pkgs `((native-inputs ,(package-lists->code pkgs))))) + ,@(match inputs + (() '()) + (pkgs `((inputs ,(package-lists->code pkgs))))) + ,@(match propagated-inputs + (() '()) + (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + ,@(if (lset= string=? supported-systems %supported-systems) + '() + `((supported-systems (list ,@supported-systems)))) + ,@(match (map search-path-specification->code native-search-paths) + (() '()) + (paths `((native-search-paths (list ,@paths))))) + ,@(match (map search-path-specification->code search-paths) + (() '()) + (paths `((search-paths (list ,@paths))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(if (list? license) + `(list ,@(map license->code license)) + (license->code license))))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 94c8cb040b..3809c3d074 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> -;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; @@ -310,7 +310,23 @@ the expected fields of an <origin> object." (uri (assoc-ref orig "uri")) (sha256 sha)))))) -(define (alist->package meta) +(define* (alist->package meta #:optional (known-inputs '())) + "Return a package value generated from the alist META. If the list of +strings KNOWN-INPUTS is provided, do not treat the mentioned inputs as +specifications to look up and replace them with plain symbols instead." + (define (process-inputs which) + (let-values (((regular known) + (lset-diff+intersection + string=? + (vector->list (or (assoc-ref meta which) #())) + known-inputs))) + (append (specs->package-lists regular) + (map string->symbol known)))) + (define (process-arguments arguments) + (append-map (match-lambda + ((key . value) + (list (symbol->keyword (string->symbol key)) value))) + arguments)) (package (name (assoc-ref meta "name")) (version (assoc-ref meta "version")) @@ -318,15 +334,13 @@ the expected fields of an <origin> object." (build-system (lookup-build-system-by-name (string->symbol (assoc-ref meta "build-system")))) - (native-inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "native-inputs") '#())))) - (inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "inputs") '#())))) - (propagated-inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "propagated-inputs") '#())))) + (arguments + (or (and=> (assoc-ref meta "arguments") + process-arguments) + '())) + (native-inputs (process-inputs "native-inputs")) + (inputs (process-inputs "inputs")) + (propagated-inputs (process-inputs "propagated-inputs")) (home-page (assoc-ref meta "home-page")) (synopsis |