diff options
Diffstat (limited to 'guix/import')
| -rw-r--r-- | guix/import/elm.scm | 210 | ||||
| -rw-r--r-- | guix/import/json.scm | 9 | ||||
| -rw-r--r-- | guix/import/utils.scm | 34 |
3 files changed, 248 insertions, 5 deletions
diff --git a/guix/import/elm.scm b/guix/import/elm.scm new file mode 100644 index 0000000000..74902b8617 --- /dev/null +++ b/guix/import/elm.scm @@ -0,0 +1,210 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix import elm) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix http-client) + #:use-module (guix memoization) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module ((guix ui) #:select (display-hint)) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version) + find-files + invoke)) + #:use-module (guix import utils) + #:use-module (guix git) + #:use-module (guix import json) + #:autoload (gcrypt hash) (hash-algorithm sha256) + #:use-module (json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix build-system elm) + #:export (elm-recursive-import + %elm-package-registry + %current-elm-checkout + elm->guix-package)) + +(define %registry-url + ;; It is much nicer to fetch this small (< 40 KB gzipped) + ;; file once than to do many HTTP requests. + "https://package.elm-lang.org/all-packages") + +(define %elm-package-registry + ;; This is a parameter to support both testing and memoization. + ;; In pseudo-code, it has the contract: + ;; (parameter/c (-> json/c) + ;; (promise/c (vhash/c string? (listof string?)))) + ;; To set the parameter, provide a thunk that returns a value suitable + ;; as an argument to 'json->registry-vhash'. Accessing the parameter + ;; returns a promise wrapping the resulting vhash. + (make-parameter + (lambda () + (cond + ((json-fetch %registry-url #:http-fetch http-fetch/cached)) + (else + (raise (formatted-message + (G_ "error downloading Elm package registry from ~a") + %registry-url))))) + (lambda (thunk) + (delay (json->registry-vhash (thunk)))))) + +(define (json->registry-vhash jsobject) + "Parse the '(json)' module's representation of the Elm package registry to a +vhash mapping package names to lists of available versions, sorted from latest +to oldest." + (fold (lambda (entry vh) + (match entry + ((name . vec) + (vhash-cons name + (sort (vector->list vec) version>?) + vh)))) + vlist-null + jsobject)) + +(define (json->direct-dependencies jsobject) + "Parse the '(json)' module's representation of an 'elm.json' file's +'dependencies' or 'test-dependencies' field to a list of strings naming direct +dependencies, handling both the 'package' and 'application' grammars." + (cond + ;; *unspecified* + ((not (pair? jsobject)) + '()) + ;; {"type":"application"} + ((every (match-lambda + (((or "direct" "indirect") (_ . _) ...) + #t) + (_ + #f)) + jsobject) + (map car (or (assoc-ref jsobject "direct") '()))) + ;; {"type":"package"} + (else + (map car jsobject)))) + +;; <project-info> handles both {"type":"package"} and {"type":"application"} +(define-json-mapping <project-info> make-project-info project-info? + json->project-info + (dependencies project-info-dependencies + "dependencies" json->direct-dependencies) + (test-dependencies project-info-test-dependencies + "test-dependencies" json->direct-dependencies) + ;; "synopsis" and "license" may be missing for {"type":"application"} + (synopsis project-info-synopsis + "summary" (lambda (x) + (if (string? x) + x + ""))) + (license project-info-license + "license" (lambda (x) + (if (string? x) + (spdx-string->license x) + #f)))) + +(define %current-elm-checkout + ;; This is a parameter for testing purposes. + (make-parameter + (lambda (name version) + (define-values (checkout _commit _relation) + ;; Elm requires that packages use this very specific format + (update-cached-checkout (string-append "https://github.com/" name) + #:ref `(tag . ,version))) + checkout))) + +(define (make-elm-package-sexp name version) + "Return two values: the `package' s-expression for the Elm package with the +given NAME and VERSION, and a list of Elm packages it depends on." + (define checkout + ((%current-elm-checkout) name version)) + (define info + (call-with-input-file (string-append checkout "/elm.json") + json->project-info)) + (define dependencies + (project-info-dependencies info)) + (define test-dependencies + (project-info-test-dependencies info)) + (define guix-name + (elm->package-name name)) + (values + `(package + (name ,guix-name) + (version ,version) + (source (elm-package-origin + ,name + version ;; no , + (base32 + ,(bytevector->nix-base32-string + (file-hash* checkout + #:algorithm (hash-algorithm sha256) + #:recursive? #t))))) + (build-system elm-build-system) + ,@(maybe-propagated-inputs (map elm->package-name dependencies)) + ,@(maybe-inputs (map elm->package-name test-dependencies)) + (home-page ,(string-append "https://package.elm-lang.org/packages/" + name "/" version)) + (synopsis ,(project-info-synopsis info)) + (description + ;; Try to use the first paragraph of README.md (which Elm requires), + ;; or fall back to synopsis otherwise. + ,(beautify-description + (match (chunk-lines (call-with-input-file + (string-append checkout "/README.md") + read-lines)) + ((_ par . _) + (string-join par " ")) + (_ + (project-info-synopsis info))))) + ,@(let ((inferred-name (infer-elm-package-name guix-name))) + (if (equal? inferred-name name) + '() + `((properties '((upstream-name . ,name)))))) + (license ,(project-info-license info))) + (append dependencies test-dependencies))) + +(define elm->guix-package + (memoize + (lambda* (package-name #:key repo version) + "Fetch the metadata for PACKAGE-NAME, an Elm package registered at +package.elm.org, and return two values: the `package' s-expression +corresponding to that package (or #f on failure) and a list of Elm +dependencies." + (cond + ((vhash-assoc package-name (force (%elm-package-registry))) + => (match-lambda + ((_found latest . _versions) + (make-elm-package-sexp package-name (or version latest))))) + (else + (values #f '())))))) + +(define* (elm-recursive-import package-name #:optional version) + (recursive-import package-name + #:version version + #:repo->guix-package elm->guix-package + #:guix-name elm->package-name)) diff --git a/guix/import/json.scm b/guix/import/json.scm index 0c98bb25b8..ae00ee929e 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -35,13 +35,16 @@ json->scheme-file)) (define* (json-fetch url + #:key + (http-fetch http-fetch) ;; Note: many websites returns 403 if we omit a ;; 'User-Agent' header. - #:key (headers `((user-agent . "GNU Guile") - (Accept . "application/json")))) + (headers `((user-agent . "GNU Guile") + (Accept . "application/json")))) "Return a representation of the JSON resource URL (a list or hash table), or #f if URL returns 403 or 404. HEADERS is a list of HTTP headers to pass in -the query." +the query. HTTP-FETCH is called to perform the request: for example, to +enable caching, supply 'http-fetch/cached'." (guard (c ((and (http-get-error? c) (let ((error (http-get-error-code c))) (or (= 403 error) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 9cadbb3d5f..26eebfece5 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -11,6 +11,7 @@ ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr> +;;; Copyright © 2022 Kyle Meyer <kyle@kyleam.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -132,7 +133,7 @@ of the string VERSION is replaced by the symbol 'version." "Convert STR, a SPDX formatted license identifier, to a license object. Return #f if STR does not match any known identifiers." ;; https://spdx.org/licenses/ - ;; The psfl, gfl1.0, nmap, repoze + ;; The gfl1.0, nmap, repoze ;; licenses doesn't have SPDX identifiers ;; ;; Please update guix/licenses.scm when modifying @@ -143,14 +144,17 @@ of the string VERSION is replaced by the symbol 'version." ;; or "GPL-N-or-later" as appropriate. Likewise for LGPL ;; and AGPL ("AGPL-1.0" 'license:agpl1) + ("AGPL-1.0-only" 'license:agpl1) ("AGPL-3.0" 'license:agpl3) ("AGPL-3.0-only" 'license:agpl3) ("AGPL-3.0-or-later" 'license:agpl3+) ("Apache-1.1" 'license:asl1.1) ("Apache-2.0" 'license:asl2.0) + ("APSL-2.0" 'license:apsl2) ("BSL-1.0" 'license:boost1.0) ("0BSD" 'license:bsd-0) - ("BSD-2-Clause-FreeBSD" 'license:bsd-2) + ("BSD-2-Clause" 'license:bsd-2) + ("BSD-2-Clause-FreeBSD" 'license:bsd-2) ;flagged as deprecated on spdx ("BSD-3-Clause" 'license:bsd-3) ("BSD-4-Clause" 'license:bsd-4) ("CC0-1.0" 'license:cc0) @@ -161,17 +165,30 @@ of the string VERSION is replaced by the symbol 'version." ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) ("CDDL-1.0" 'license:cddl1.0) + ("CDDL-1.1" 'license:cddl1.1) + ("CECILL-2.1" 'license:cecill) + ("CECILL-B" 'license:cecill-b) ("CECILL-C" 'license:cecill-c) ("Artistic-2.0" 'license:artistic2.0) ("ClArtistic" 'license:clarified-artistic) + ("copyleft-next-0.3.0" 'license:copyleft-next) ("CPL-1.0" 'license:cpl1.0) ("EPL-1.0" 'license:epl1.0) + ("EPL-2.0" 'license:epl2.0) + ("EUPL-1.2" 'license:eupl1.2) ("MIT" 'license:expat) + ("MIT-0" 'license:expat-0) ("FTL" 'license:freetype) + ("FreeBSD-DOC" 'license:freebsd-doc) ("Freetype" 'license:freetype) + ("FSFAP" 'license:fsf-free) + ("FSFUL" 'license:fsf-free) ("GFDL-1.1" 'license:fdl1.1+) + ("GFDL-1.1-or-later" 'license:fdl1.1+) ("GFDL-1.2" 'license:fdl1.2+) + ("GFDL-1.2-or-later" 'license:fdl1.2+) ("GFDL-1.3" 'license:fdl1.3+) + ("GFDL-1.3-or-later" 'license:fdl1.3+) ("Giftware" 'license:giftware) ("GPL-1.0" 'license:gpl1) ("GPL-1.0-only" 'license:gpl1) @@ -204,14 +221,24 @@ of the string VERSION is replaced by the symbol 'version." ("LGPL-3.0-only" 'license:lgpl3) ("LGPL-3.0+" 'license:lgpl3+) ("LGPL-3.0-or-later" 'license:lgpl3+) + ("LPPL-1.0" 'license:lppl) + ("LPPL-1.1" 'license:lppl) + ("LPPL-1.2" 'license:lppl1.2) + ("LPPL-1.3a" 'license:lppl1.3a) + ("LPPL-1.3c" 'license:lppl1.3c) + ("MirOS" 'license:miros) ("MPL-1.0" 'license:mpl1.0) ("MPL-1.1" 'license:mpl1.1) ("MPL-2.0" 'license:mpl2.0) ("MS-PL" 'license:ms-pl) ("NCSA" 'license:ncsa) + ("OGL-UK-1.0" 'license:ogl-psi1.0) ("OpenSSL" 'license:openssl) ("OLDAP-2.8" 'license:openldap2.8) + ("OPL-1.0" 'license:opl1.0+) ("CUA-OPL-1.0" 'license:cua-opl1.0) + ("PSF-2.0" 'license:psfl) + ("OSL-2.1" 'license:osl2.1) ("QPL-1.0" 'license:qpl) ("Ruby" 'license:ruby) ("SGI-B-2.0" 'license:sgifreeb2.0) @@ -220,6 +247,9 @@ of the string VERSION is replaced by the symbol 'version." ("TCL" 'license:tcl/tk) ("Unlicense" 'license:unlicense) ("Vim" 'license:vim) + ("W3C" 'license:w3c) + ("WTFPL" 'license:wtfpl2) + ("wxWindow" 'license:wxwindows3.1+) ;flagged as deprecated on spdx ("X11" 'license:x11) ("ZPL-2.1" 'license:zpl2.1) ("Zlib" 'license:zlib) |