200 lines
7.4 KiB
Scheme
200 lines
7.4 KiB
Scheme
;;; 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 vlist)
|
|
#:use-module (srfi srfi-1)
|
|
#: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 import utils)
|
|
#:use-module (guix git)
|
|
#:use-module (guix import json)
|
|
#:autoload (gcrypt hash) (hash-algorithm sha256)
|
|
#:use-module (json)
|
|
#: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 version #:allow-other-keys)
|
|
"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))
|